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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
|
%
% (c) The University of Glasgow 2000
%
\section[ByteCodeLink]{Bytecode assembler and linker}
\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module ByteCodeLink (
HValue,
ClosureEnv, emptyClosureEnv, extendClosureEnv,
linkBCO, lookupStaticPtr
) where
#include "HsVersions.h"
import ByteCodeItbls ( ItblEnv, ItblPtr )
import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
import ObjLink ( lookupSymbol )
import Name ( Name, nameModule, nameOccName, isExternalName )
import NameEnv
import OccName ( occNameFS )
import PrimOp ( PrimOp, primOpOcc )
import Module ( moduleFS )
import FastString ( FastString(..), unpackFS, zEncodeFS )
import Outputable
import Panic ( GhcException(..) )
-- Standard libraries
import GHC.Word ( Word(..) )
import Data.Array.IArray ( listArray )
import Data.Array.Base
import GHC.Arr ( STArray(..) )
import Control.Exception ( throwDyn )
import Control.Monad ( zipWithM )
import Control.Monad.ST ( stToIO )
import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) )
import GHC.Base ( writeArray#, RealWorld, Int(..) )
\end{code}
%************************************************************************
%* *
\subsection{Linking interpretables into something we can run}
%* *
%************************************************************************
\begin{code}
type ClosureEnv = NameEnv (Name, HValue)
newtype HValue = HValue (forall a . a)
emptyClosureEnv = emptyNameEnv
extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
= extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
\end{code}
%************************************************************************
%* *
\subsection{Linking interpretables into something we can run}
%* *
%************************************************************************
\begin{code}
{-
data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
ByteArray# -- literals :: Array Word32#
PtrArray# -- ptrs :: Array HValue
ByteArray# -- itbls :: Array Addr#
-}
linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
linkBCO ie ce ul_bco
= do BCO bco# <- linkBCO' ie ce ul_bco
-- SDM: Why do we need mkApUpd0 here? I *think* it's because
-- otherwise top-level interpreted CAFs don't get updated
-- after evaluation. A top-level BCO will evaluate itself and
-- return its value when entered, but it won't update itself.
-- Wrapping the BCO in an AP_UPD thunk will take care of the
-- update for us.
--
-- Update: the above is true, but now we also have extra invariants:
-- (a) An AP thunk *must* point directly to a BCO
-- (b) A zero-arity BCO *must* be wrapped in an AP thunk
-- (c) An AP is always fully saturated, so we *can't* wrap
-- non-zero arity BCOs in an AP thunk.
--
if (unlinkedBCOArity ul_bco > 0)
then return (unsafeCoerce# bco#)
else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
-- Raises an IO exception on failure
= do let literals = ssElts literalsSS
ptrs = ssElts ptrsSS
itbls = ssElts itblsSS
linked_itbls <- mapM (lookupIE ie) itbls
linked_literals <- mapM lookupLiteral literals
let n_literals = sizeSS literalsSS
n_ptrs = sizeSS ptrsSS
n_itbls = sizeSS itblsSS
ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
let
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
itbls_arr = listArray (0, n_itbls-1) linked_itbls
:: UArray Int ItblPtr
itbls_barr = case itbls_arr of UArray lo hi barr -> barr
literals_arr = listArray (0, n_literals-1) linked_literals
:: UArray Int Word
literals_barr = case literals_arr of UArray lo hi barr -> barr
(I# arity#) = arity
newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
-- we recursively link any sub-BCOs while making the ptrs array
mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
mkPtrsArray ie ce n_ptrs ptrs = do
marr <- newArray_ (0, n_ptrs-1)
let
fill (BCOPtrName n) i = do
ptr <- lookupName ce n
unsafeWrite marr i ptr
fill (BCOPtrPrimOp op) i = do
ptr <- lookupPrimOp op
unsafeWrite marr i ptr
fill (BCOPtrBCO ul_bco) i = do
BCO bco# <- linkBCO' ie ce ul_bco
writeArrayBCO marr i bco#
zipWithM fill ptrs [0..]
unsafeFreeze marr
newtype IOArray i e = IOArray (STArray RealWorld i e)
instance HasBounds IOArray where
bounds (IOArray marr) = bounds marr
instance MArray IOArray e IO where
newArray lu init = stToIO $ do
marr <- newArray lu init; return (IOArray marr)
newArray_ lu = stToIO $ do
marr <- newArray_ lu; return (IOArray marr)
unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
(# s#, () #) }
data BCO = BCO BCO#
newBCO :: ByteArray# -> ByteArray# -> Array# a
-> ByteArray# -> Int# -> ByteArray# -> IO BCO
newBCO instrs lits ptrs itbls arity bitmap
= IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
(# s1, bco #) -> (# s1, BCO bco #)
lookupLiteral :: Either Word FastString -> IO Word
lookupLiteral (Left lit) = return lit
lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
return (W# (unsafeCoerce# addr))
-- Can't be bothered to find the official way to convert Addr# to Word#;
-- the FFI/Foreign designers make it too damn difficult
-- Hence we apply the Blunt Instrument, which works correctly
-- on all reasonable architectures anyway
lookupStaticPtr :: FastString -> IO (Ptr ())
lookupStaticPtr addr_of_label_string
= do let label_to_find = unpackFS addr_of_label_string
m <- lookupSymbol label_to_find
case m of
Just ptr -> return ptr
Nothing -> linkFail "ByteCodeLink: can't find label"
label_to_find
lookupPrimOp :: PrimOp -> IO HValue
lookupPrimOp primop
= do let sym_to_find = primopToCLabel primop "closure"
m <- lookupSymbol sym_to_find
case m of
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> return hval
Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
lookupName :: ClosureEnv -> Name -> IO HValue
lookupName ce nm
= case lookupNameEnv ce nm of
Just (_,aa) -> return aa
Nothing
-> ASSERT2(isExternalName nm, ppr nm)
do let sym_to_find = nameToCLabel nm "closure"
m <- lookupSymbol sym_to_find
case m of
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> return hval
Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
= case lookupNameEnv ie con_nm of
Just (_, Ptr a) -> return (Ptr a)
Nothing
-> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
m <- lookupSymbol 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 sym_to_find2
case n of
Just addr -> return addr
Nothing -> linkFail "ByteCodeLink.lookupIE"
(sym_to_find1 ++ " or " ++ sym_to_find2)
linkFail :: String -> String -> IO a
linkFail who what
= throwDyn (ProgramError $
unlines [ ""
, "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 send a bug report to:"
, " glasgow-haskell-bugs@haskell.org"
])
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
= unpackFS (zEncodeFS (moduleFS (nameModule n)))
++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix
primopToCLabel :: PrimOp -> String{-suffix-} -> String
primopToCLabel primop suffix
= let str = "GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
in --trace ("primopToCLabel: " ++ str)
str
\end{code}
|