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