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