summaryrefslogtreecommitdiff
path: root/ghc/compiler/ghci/ByteCodeLink.lhs
blob: 875f1d63314c9d4e645432db550931f5759929a8 (plain)
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}