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