Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / ghci / ByteCodeItbls.lhs
1 %
2 % (c) The University of Glasgow 2000-2006
3 %
4 ByteCodeItbls: Generate infotables for interpreter-made bytecodes
5
6 \begin{code}
7 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
8
9 module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
10                      , StgInfoTable(..)
11                      ) where
12
13 #include "HsVersions.h"
14
15 import Name             ( Name, getName )
16 import NameEnv
17 import ClosureInfo
18 import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
19 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
20 import Constants        ( mIN_PAYLOAD_SIZE, wORD_SIZE )
21 import CgHeapery        ( mkVirtHeapOffsets )
22 import Util
23
24 import Foreign
25 import Foreign.C
26
27 import GHC.Exts         ( Int(I#), addr2Int# )
28 import GHC.Ptr          ( Ptr(..) )
29 \end{code}
30
31 %************************************************************************
32 %*                                                                      *
33 \subsection{Manufacturing of info tables for DataCons}
34 %*                                                                      *
35 %************************************************************************
36
37 \begin{code}
38 newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
39
40 itblCode :: ItblPtr -> Ptr ()
41 itblCode (ItblPtr ptr)
42  | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB
43  | otherwise            = castPtr ptr
44
45 -- XXX bogus
46 conInfoTableSizeB :: Int
47 conInfoTableSizeB = 3 * wORD_SIZE
48
49 type ItblEnv = NameEnv (Name, ItblPtr)
50         -- We need the Name in the range so we know which
51         -- elements to filter out when unloading a module
52
53 mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
54 mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
55
56
57 -- Make info tables for the data decls in this module
58 mkITbls :: [TyCon] -> IO ItblEnv
59 mkITbls [] = return emptyNameEnv
60 mkITbls (tc:tcs) = do itbls  <- mkITbl tc
61                       itbls2 <- mkITbls tcs
62                       return (itbls `plusNameEnv` itbls2)
63
64 mkITbl :: TyCon -> IO ItblEnv
65 mkITbl tc
66    | not (isDataTyCon tc) 
67    = return emptyNameEnv
68    | dcs `lengthIs` n -- paranoia; this is an assertion.
69    = make_constr_itbls dcs
70      where
71         dcs = tyConDataCons tc
72         n   = tyConFamilySize tc
73
74 mkITbl _ = error "Unmatched patter in mkITbl: assertion failed!"
75
76 #include "../includes/rts/storage/ClosureTypes.h"
77 cONSTR :: Int   -- Defined in ClosureTypes.h
78 cONSTR = CONSTR 
79
80 -- Assumes constructors are numbered from zero, not one
81 make_constr_itbls :: [DataCon] -> IO ItblEnv
82 make_constr_itbls cons
83    = do is <- mapM mk_dirret_itbl (zip cons [0..])
84         return (mkItblEnv is)
85      where
86         mk_dirret_itbl (dcon, conNo)
87            = mk_itbl dcon conNo stg_interp_constr_entry
88
89         mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
90         mk_itbl dcon conNo entry_addr = do
91            let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ]
92                (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
93
94                ptrs'  = ptr_wds
95                nptrs' = tot_wds - ptr_wds
96                nptrs_really
97                   | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE = nptrs'
98                   | otherwise = mIN_PAYLOAD_SIZE - ptrs'
99                code' = mkJumpToAddr entry_addr
100                itbl  = StgInfoTable {
101 #ifndef GHCI_TABLES_NEXT_TO_CODE
102                            entry = entry_addr,
103 #endif
104                            ptrs  = fromIntegral ptrs', 
105                            nptrs = fromIntegral nptrs_really,
106                            tipe  = fromIntegral cONSTR,
107                            srtlen = fromIntegral conNo
108 #ifdef GHCI_TABLES_NEXT_TO_CODE
109                          , code  = code'
110 #endif
111                         }
112            qNameCString <- newArray0 0 $ dataConIdentity dcon 
113            let conInfoTbl = StgConInfoTable {
114                                  conDesc = qNameCString,
115                                  infoTable = itbl
116                             }
117                -- Make a piece of code to jump to "entry_label".
118                -- This is the only arch-dependent bit.
119            addrCon <- newExec pokeConItbl conInfoTbl
120                     --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
121                     --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
122                     --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
123            return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
124
125
126 -- Make code which causes a jump to the given address.  This is the
127 -- only arch-dependent bit of the itbl story.  The returned list is
128 -- itblCodeLength elements (bytes) long.
129
130 -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
131 #include "nativeGen/NCG.h"
132
133 itblCodeLength :: Int
134 itblCodeLength = length (mkJumpToAddr undefined)
135
136 mkJumpToAddr :: Ptr () -> [ItblCode]
137
138 ptrToInt :: Ptr a -> Int
139 ptrToInt (Ptr a#) = I# (addr2Int# a#)
140
141 #if sparc_TARGET_ARCH
142 -- After some consideration, we'll try this, where
143 -- 0x55555555 stands in for the address to jump to.
144 -- According to includes/rts/MachRegs.h, %g3 is very
145 -- likely indeed to be baggable.
146 --
147 --   0000 07155555              sethi   %hi(0x55555555), %g3
148 --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
149 --   0008 81C0C000              jmp     %g3
150 --   000c 01000000              nop
151
152 type ItblCode = Word32
153 mkJumpToAddr a
154    = let w32 = fromIntegral (ptrToInt a)
155
156          hi22, lo10 :: Word32 -> Word32
157          lo10 x = x .&. 0x3FF
158          hi22 x = (x `shiftR` 10) .&. 0x3FFFF
159
160      in  [ 0x07000000 .|. (hi22 w32),
161            0x8610E000 .|. (lo10 w32),
162            0x81C0C000,
163            0x01000000 ]
164
165 #elif powerpc_TARGET_ARCH
166 -- We'll use r12, for no particular reason.
167 -- 0xDEADBEEF stands for the adress:
168 -- 3D80DEAD lis r12,0xDEAD
169 -- 618CBEEF ori r12,r12,0xBEEF
170 -- 7D8903A6 mtctr r12
171 -- 4E800420 bctr
172
173 type ItblCode = Word32
174 mkJumpToAddr a =
175     let w32 = fromIntegral (ptrToInt a)
176         hi16 x = (x `shiftR` 16) .&. 0xFFFF
177         lo16 x = x .&. 0xFFFF
178     in  [
179         0x3D800000 .|. hi16 w32,
180         0x618C0000 .|. lo16 w32,
181         0x7D8903A6, 0x4E800420
182         ]
183
184 #elif i386_TARGET_ARCH
185 -- Let the address to jump to be 0xWWXXYYZZ.
186 -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
187 -- which is
188 -- B8 ZZ YY XX WW FF E0
189
190 type ItblCode = Word8
191 mkJumpToAddr a
192    = let w32 = fromIntegral (ptrToInt a) :: Word32
193          insnBytes :: [Word8]
194          insnBytes
195             = [0xB8, byte0 w32, byte1 w32, 
196                      byte2 w32, byte3 w32, 
197                0xFF, 0xE0]
198      in
199          insnBytes
200
201 #elif x86_64_TARGET_ARCH
202 -- Generates:
203 --      jmpq *.L1(%rip)
204 --      .align 8
205 -- .L1: 
206 --      .quad <addr>
207 --
208 -- We need a full 64-bit pointer (we can't assume the info table is
209 -- allocated in low memory).  Assuming the info pointer is aligned to
210 -- an 8-byte boundary, the addr will also be aligned.
211
212 type ItblCode = Word8
213 mkJumpToAddr a
214    = let w64 = fromIntegral (ptrToInt a) :: Word64
215          insnBytes :: [Word8]
216          insnBytes
217             = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
218                byte0 w64, byte1 w64, byte2 w64, byte3 w64,
219                byte4 w64, byte5 w64, byte6 w64, byte7 w64]
220      in
221          insnBytes
222
223 #elif alpha_TARGET_ARCH
224 type ItblCode = Word32
225 mkJumpToAddr a
226     = [ 0xc3800000      -- br   at, .+4
227       , 0xa79c000c      -- ldq  at, 12(at)
228       , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
229       , 0x47ff041f      -- nop
230       , fromIntegral (w64 .&. 0x0000FFFF)
231       , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
232     where w64 = fromIntegral (ptrToInt a) :: Word64
233
234 #else
235 type ItblCode = Word32
236 mkJumpToAddr a
237     = undefined
238 #endif
239
240 #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
241 byte0, byte1, byte2, byte3 :: (Integral w, Bits w) => w -> Word8
242 byte0 w = fromIntegral w
243 byte1 w = fromIntegral (w `shiftR` 8)
244 byte2 w = fromIntegral (w `shiftR` 16)
245 byte3 w = fromIntegral (w `shiftR` 24)
246 #endif
247
248 #if defined(x86_64_TARGET_ARCH)
249 byte4, byte5, byte6, byte7 :: (Integral w, Bits w) => w -> Word8
250 byte4 w = fromIntegral (w `shiftR` 32)
251 byte5 w = fromIntegral (w `shiftR` 40)
252 byte6 w = fromIntegral (w `shiftR` 48)
253 byte7 w = fromIntegral (w `shiftR` 56)
254 #endif
255
256 #ifndef __HADDOCK__
257 -- entry point for direct returns for created constr itbls
258 foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
259 #endif
260
261
262
263
264 -- Ultra-minimalist version specially for constructors
265 #if SIZEOF_VOID_P == 8
266 type HalfWord = Word32
267 #else
268 type HalfWord = Word16
269 #endif
270
271 data StgConInfoTable = StgConInfoTable {
272    conDesc   :: Ptr Word8,
273    infoTable :: StgInfoTable
274 }
275
276 instance Storable StgConInfoTable where
277    sizeOf conInfoTable    
278       = sum [ sizeOf (conDesc conInfoTable)
279             , sizeOf (infoTable conInfoTable) ]
280    alignment _ = SIZEOF_VOID_P
281    peek ptr 
282       = runState (castPtr ptr) $ do
283 #ifdef GHCI_TABLES_NEXT_TO_CODE
284            desc <- load
285 #endif
286            itbl <- load
287 #ifndef GHCI_TABLES_NEXT_TO_CODE
288            desc <- load
289 #endif
290            return  
291               StgConInfoTable 
292               { 
293 #ifdef GHCI_TABLES_NEXT_TO_CODE
294                 conDesc   = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc
295 #else
296                 conDesc   = desc
297 #endif
298               , infoTable = itbl
299               }
300    poke = error "poke(StgConInfoTable): use pokeConItbl instead"
301
302
303 pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
304             -> IO ()
305 pokeConItbl wr_ptr ex_ptr itbl 
306       = runState (castPtr wr_ptr) $ do
307 #ifdef GHCI_TABLES_NEXT_TO_CODE
308            store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB))
309 #endif
310            store (infoTable itbl)
311 #ifndef GHCI_TABLES_NEXT_TO_CODE
312            store (conDesc itbl)
313 #endif
314
315 data StgInfoTable = StgInfoTable {
316 #ifndef GHCI_TABLES_NEXT_TO_CODE
317    entry  :: Ptr (),
318 #endif
319    ptrs   :: HalfWord,
320    nptrs  :: HalfWord,
321    tipe   :: HalfWord,
322    srtlen :: HalfWord
323 #ifdef GHCI_TABLES_NEXT_TO_CODE
324  , code   :: [ItblCode]
325 #endif
326   }
327
328 instance Storable StgInfoTable where
329
330    sizeOf itbl 
331       = sum
332         [
333 #ifndef GHCI_TABLES_NEXT_TO_CODE
334          fieldSz entry itbl,
335 #endif
336          fieldSz ptrs itbl,
337          fieldSz nptrs itbl,
338          fieldSz tipe itbl,
339          fieldSz srtlen itbl
340 #ifdef GHCI_TABLES_NEXT_TO_CODE
341         ,fieldSz (head.code) itbl * itblCodeLength
342 #endif
343         ]
344
345    alignment _ 
346       = SIZEOF_VOID_P
347
348    poke a0 itbl
349       = runState (castPtr a0)
350       $ do
351 #ifndef GHCI_TABLES_NEXT_TO_CODE
352            store (entry  itbl)
353 #endif
354            store (ptrs   itbl)
355            store (nptrs  itbl)
356            store (tipe   itbl)
357            store (srtlen itbl)
358 #ifdef GHCI_TABLES_NEXT_TO_CODE
359            sequence_ (map store (code itbl))
360 #endif
361
362    peek a0
363       = runState (castPtr a0)
364       $ do
365 #ifndef GHCI_TABLES_NEXT_TO_CODE
366            entry'  <- load
367 #endif
368            ptrs'   <- load
369            nptrs'  <- load
370            tipe'   <- load
371            srtlen' <- load
372 #ifdef GHCI_TABLES_NEXT_TO_CODE
373            code'   <- sequence (replicate itblCodeLength load)
374 #endif
375            return 
376               StgInfoTable { 
377 #ifndef GHCI_TABLES_NEXT_TO_CODE
378                  entry  = entry',
379 #endif
380                  ptrs   = ptrs',
381                  nptrs  = nptrs',
382                  tipe   = tipe',
383                  srtlen = srtlen'
384 #ifdef GHCI_TABLES_NEXT_TO_CODE
385                 ,code   = code'
386 #endif
387               }
388
389 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
390 fieldSz sel x = sizeOf (sel x)
391
392 newtype State s m a = State (s -> m (s, a))
393
394 instance Monad m => Monad (State s m) where
395   return a      = State (\s -> return (s, a))
396   State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
397   fail str      = State (\_ -> fail str)
398
399 class (Monad m, Monad (t m)) => MonadT t m where
400   lift :: m a -> t m a
401
402 instance Monad m => MonadT (State s) m where
403   lift m        = State (\s -> m >>= \a -> return (s, a))
404
405 runState :: (Monad m) => s -> State s m a -> m a
406 runState s (State m) = m s >>= return . snd
407
408 type PtrIO = State (Ptr Word8) IO
409
410 advance :: Storable a => PtrIO (Ptr a)
411 advance = State adv where
412     adv addr = case castPtr addr of { addrCast -> return
413         (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
414
415 sizeOfPointee :: (Storable a) => Ptr a -> Int
416 sizeOfPointee addr = sizeOf (typeHack addr)
417     where typeHack = undefined :: Ptr a -> a
418
419 store :: Storable a => a -> PtrIO ()
420 store x = do addr <- advance
421              lift (poke addr x)
422
423 load :: Storable a => PtrIO a
424 load = do addr <- advance
425           lift (peek addr)
426
427
428 newExec :: Storable a => (Ptr a -> Ptr a -> a -> IO ()) -> a -> IO (FunPtr ())
429 newExec poke_fn obj
430    = alloca $ \pcode -> do
431         wr_ptr <- _allocateExec (fromIntegral (sizeOf obj)) pcode
432         ex_ptr <- peek pcode
433         poke_fn wr_ptr ex_ptr obj
434         return (castPtrToFunPtr ex_ptr)
435
436 foreign import ccall unsafe "allocateExec"
437   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)  
438 \end{code}