Avoid linear lookup in unload_wkr in the Linker
[ghc.git] / compiler / ghci / ByteCodeLink.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MagicHash #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE UnboxedTuples #-}
7 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
8 --
9 -- (c) The University of Glasgow 2002-2006
10 --
11
12 -- | ByteCodeLink: Bytecode assembler and linker
13 module ByteCodeLink (
14 ClosureEnv, emptyClosureEnv, extendClosureEnv,
15 linkBCO, lookupStaticPtr,
16 lookupIE,
17 nameToCLabel, linkFail
18 ) where
19
20 #include "HsVersions.h"
21
22 import GHCi.RemoteTypes
23 import GHCi.ResolvedBCO
24 import GHCi.InfoTable
25 import GHCi.BreakArray
26 import SizedSeq
27
28 import GHCi
29 import ByteCodeTypes
30 import HscTypes
31 import Name
32 import NameEnv
33 import PrimOp
34 import Module
35 import FastString
36 import Panic
37 import Outputable
38 import Util
39
40 -- Standard libraries
41 import Data.Array.Unboxed
42 import Foreign.Ptr
43 import GHC.IO ( IO(..) )
44 import GHC.Exts
45
46 {-
47 Linking interpretables into something we can run
48 -}
49
50 type ClosureEnv = NameEnv (Name, ForeignHValue)
51
52 emptyClosureEnv :: ClosureEnv
53 emptyClosureEnv = emptyNameEnv
54
55 extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
56 extendClosureEnv cl_env pairs
57 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
58
59 {-
60 Linking interpretables into something we can run
61 -}
62
63 linkBCO
64 :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
65 -> UnlinkedBCO
66 -> IO ResolvedBCO
67 linkBCO hsc_env ie ce bco_ix breakarray
68 (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
69 -- fromIntegral Word -> Word64 should be a no op if Word is Word64
70 -- otherwise it will result in a cast to longlong on 32bit systems.
71 lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)
72 ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
73 return (ResolvedBCO isLittleEndian arity insns bitmap
74 (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
75 (addListToSS emptySS ptrs))
76
77 lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
78 lookupLiteral _ _ (BCONPtrWord lit) = return lit
79 lookupLiteral hsc_env _ (BCONPtrLbl sym) = do
80 Ptr a# <- lookupStaticPtr hsc_env sym
81 return (W# (int2Word# (addr2Int# a#)))
82 lookupLiteral hsc_env ie (BCONPtrItbl nm) = do
83 Ptr a# <- lookupIE hsc_env ie nm
84 return (W# (int2Word# (addr2Int# a#)))
85 lookupLiteral _ _ (BCONPtrStr _) =
86 -- should be eliminated during assembleBCOs
87 panic "lookupLiteral: BCONPtrStr"
88
89 lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
90 lookupStaticPtr hsc_env addr_of_label_string = do
91 m <- lookupSymbol hsc_env addr_of_label_string
92 case m of
93 Just ptr -> return ptr
94 Nothing -> linkFail "ByteCodeLink: can't find label"
95 (unpackFS addr_of_label_string)
96
97 lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
98 lookupIE hsc_env ie con_nm =
99 case lookupNameEnv ie con_nm of
100 Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
101 Nothing -> do -- try looking up in the object files.
102 let sym_to_find1 = nameToCLabel con_nm "con_info"
103 m <- lookupSymbol hsc_env sym_to_find1
104 case m of
105 Just addr -> return addr
106 Nothing
107 -> do -- perhaps a nullary constructor?
108 let sym_to_find2 = nameToCLabel con_nm "static_info"
109 n <- lookupSymbol hsc_env sym_to_find2
110 case n of
111 Just addr -> return addr
112 Nothing -> linkFail "ByteCodeLink.lookupIE"
113 (unpackFS sym_to_find1 ++ " or " ++
114 unpackFS sym_to_find2)
115
116 lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
117 lookupPrimOp hsc_env primop = do
118 let sym_to_find = primopToCLabel primop "closure"
119 m <- lookupSymbol hsc_env (mkFastString sym_to_find)
120 case m of
121 Just p -> return (toRemotePtr p)
122 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
123
124 resolvePtr
125 :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
126 -> BCOPtr
127 -> IO ResolvedBCOPtr
128 resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
129 | Just ix <- lookupNameEnv bco_ix nm =
130 return (ResolvedBCORef ix) -- ref to another BCO in this group
131 | Just (_, rhv) <- lookupNameEnv ce nm =
132 return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
133 | otherwise =
134 ASSERT2(isExternalName nm, ppr nm)
135 do let sym_to_find = nameToCLabel nm "closure"
136 m <- lookupSymbol hsc_env sym_to_find
137 case m of
138 Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
139 Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
140 resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
141 ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
142 resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
143 ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
144 resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
145 return (ResolvedBCOPtrBreakArray breakarray)
146
147 linkFail :: String -> String -> IO a
148 linkFail who what
149 = throwGhcExceptionIO (ProgramError $
150 unlines [ "",who
151 , "During interactive linking, GHCi couldn't find the following symbol:"
152 , ' ' : ' ' : what
153 , "This may be due to you not asking GHCi to load extra object files,"
154 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
155 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
156 , "flags, or simply by naming the relevant files on the GHCi command line."
157 , "Alternatively, this link failure might indicate a bug in GHCi."
158 , "If you suspect the latter, please send a bug report to:"
159 , " glasgow-haskell-bugs@haskell.org"
160 ])
161
162
163 nameToCLabel :: Name -> String -> FastString
164 nameToCLabel n suffix = mkFastString label
165 where
166 encodeZ = zString . zEncodeFS
167 (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
168 packagePart = encodeZ (unitIdFS pkgKey)
169 modulePart = encodeZ (moduleNameFS modName)
170 occPart = encodeZ (occNameFS (nameOccName n))
171
172 label = concat
173 [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
174 , modulePart
175 , '_':occPart
176 , '_':suffix
177 ]
178
179
180 primopToCLabel :: PrimOp -> String -> String
181 primopToCLabel primop suffix = concat
182 [ "ghczmprim_GHCziPrimopWrappers_"
183 , zString (zEncodeFS (occNameFS (primOpOcc primop)))
184 , '_':suffix
185 ]