Tag pointers in interpreted constructors
[ghc.git] / compiler / ghci / ByteCodeItbls.hs
1 {-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
2 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
3 --
4 -- (c) The University of Glasgow 2002-2006
5 --
6
7 -- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
8 module ByteCodeItbls ( mkITbls ) where
9
10 #include "HsVersions.h"
11
12 import ByteCodeTypes
13 import GHCi
14 import DynFlags
15 import HscTypes
16 import Name ( Name, getName )
17 import NameEnv
18 import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
19 import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
20 import Type ( flattenRepType, repType, typePrimRep )
21 import StgCmmLayout ( mkVirtHeapOffsets )
22 import StgCmmClosure ( tagForCon )
23 import Util
24 import Panic
25
26 {-
27 Manufacturing of info tables for DataCons
28 -}
29
30 -- Make info tables for the data decls in this module
31 mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
32 mkITbls hsc_env tcs =
33 foldr plusNameEnv emptyNameEnv <$>
34 mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
35 where
36 mkITbl :: HscEnv -> TyCon -> IO ItblEnv
37 mkITbl hsc_env tc
38 | dcs `lengthIs` n -- paranoia; this is an assertion.
39 = make_constr_itbls hsc_env dcs
40 where
41 dcs = tyConDataCons tc
42 n = tyConFamilySize tc
43 mkITbl _ _ = panic "mkITbl"
44
45 mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
46 mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
47
48 -- Assumes constructors are numbered from zero, not one
49 make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
50 make_constr_itbls hsc_env cons =
51 mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
52 where
53 dflags = hsc_dflags hsc_env
54
55 mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
56 mk_itbl dcon conNo = do
57 let rep_args = [ (typePrimRep rep_arg,rep_arg)
58 | arg <- dataConRepArgTys dcon
59 , rep_arg <- flattenRepType (repType arg) ]
60
61 (tot_wds, ptr_wds, _) =
62 mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
63
64 ptrs' = ptr_wds
65 nptrs' = tot_wds - ptr_wds
66 nptrs_really
67 | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
68 | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
69
70 descr = dataConIdentity dcon
71
72 r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
73 conNo (tagForCon dflags dcon) descr)
74 return (getName dcon, ItblPtr r)