%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.51 2002/12/11 15:36:21 simonmar Exp $
+% $Id: AbsCSyn.lhs,v 1.52 2003/05/14 09:13:52 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
import Unique ( Unique )
import StgSyn ( StgOp )
import TyCon ( TyCon )
-import BitSet -- for liveness masks
+import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE )
+import SMRep ( StgWord, StgHalfWord )
import FastTypes
import FastString
\end{code}
| CSRT CLabel [CLabel] -- SRT declarations: basically an array of
-- pointers to static closures.
- | CBitmap Liveness -- A bitmap to be emitted if and only if
- -- it is larger than a target machine word.
+ | CBitmap Liveness -- A "large" bitmap to be emitted
+
+ | CSRTDesc -- A "large" SRT descriptor (one that doesn't
+ -- fit into the half-word bitmap in the itbl).
+ !CLabel -- Label for this SRT descriptor
+ !CLabel -- Pointer to the SRT
+ !Int -- Offset within the SRT
+ !Int -- Length
+ !Bitmap -- Bitmap
| CClosureInfoAndCode
ClosureInfo -- Explains placement and layout of closure
-- we add a label for the table, and expect only the 'offset/length' form
data C_SRT = NoC_SRT
- | C_SRT CLabel !Int{-offset-} !Int{-length-}
+ | C_SRT !CLabel !Int{-offset-} !StgHalfWord{-bitmap or escape-}
needsSRT :: C_SRT -> Bool
needsSRT NoC_SRT = False
!PrimRep -- the kind of the result
CExprMacro -- the macro to generate a value
[CAddrMode] -- and its arguments
-
- | CBytesPerWord -- Word size, in bytes, on this platform
- -- required for: half-word loads (used in fishing tags
- -- out of info tables), and sizeofByteArray#.
\end{code}
Various C macros for values which are dependent on the back-end layout.
mkIntCLit :: Int -> CAddrMode
mkIntCLit i = CLit (mkMachInt (toInteger i))
+mkWordCLit :: StgWord -> CAddrMode
+mkWordCLit wd = CLit (MachWord (fromIntegral wd))
+
mkCString :: FastString -> CAddrMode
mkCString s = CLit (MachStr s)
In the compiled program, liveness bitmaps that fit inside a single
word (StgWord) are stored as a single word, while larger bitmaps are
-stored as a pointer to an array of words. When we compile via C
-(especially when we bootstrap via HC files), we generate identical C
-code regardless of whether words are 32- or 64-bit on the target
-machine, by postponing the decision of how to store each liveness
-bitmap to C compilation time (or rather, C preprocessing time).
+stored as a pointer to an array of words.
\begin{code}
-type LivenessMask = [BitSet]
+data Liveness = Liveness CLabel !Int Bitmap
-data Liveness = Liveness CLabel !Int LivenessMask
+maybeLargeBitmap :: Liveness -> AbstractC
+maybeLargeBitmap liveness@(Liveness _ size _)
+ | size <= mAX_SMALL_BITMAP_SIZE = AbsCNop
+ | otherwise = CBitmap liveness
\end{code}
%************************************************************************
import Outputable
import Panic ( panic )
import FastTypes
+import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
import Maybe ( isJust )
flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CSRTDesc _ _ _ _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
-- why it needs to take into account endianness.
--
mkHalfWord_HIADDR res arg
- = mkTemp IntRep `thenFlt` \ t_hw_shift ->
- mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
+ = mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
mkTemp WordRep `thenFlt` \ t_hw_mask2 ->
- let a_hw_shift
- = CMachOpStmt t_hw_shift
- MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing
+ let
+ hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
+
a_hw_mask1
= CMachOpStmt t_hw_mask1
- MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing
+ MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
a_hw_mask2
= CMachOpStmt t_hw_mask2
MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
final
# if WORDS_BIGENDIAN
- = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2,
+ = CSequential [ a_hw_mask1, a_hw_mask2,
CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
]
# else
- = CSequential [ a_hw_shift,
- CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing
- ]
+ = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
# endif
in
returnFlt final
(if isDefinitelyInlineMachOp mop then Nothing else Just vols)
]
-getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode)
-getBitsPerWordMinus1
- = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] ->
- returnFlt (
- CSequential [
- CMachOpStmt t1 MO_Nat_Shl
- [CBytesPerWord, CLit (mkMachInt 3)] Nothing,
- CMachOpStmt t2 MO_Nat_Sub
- [t1, CLit (mkMachInt 1)] Nothing
- ],
- t2
- )
-
-- IA64 mangler doesn't place tables next to code
tablesNextToCode :: Bool
#ifdef ia64_TARGET_ARCH
c = t4 >>unsigned BITS_IN(I_)-1
-}
= mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
- getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
+ let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
(returnFlt . CSequential) [
CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
- bpw1_code,
- CMachOpStmt res_c MO_Nat_Shr [t4, bpw1_t] Nothing
+ CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing
]
c = t3 >>unsigned BITS_IN(I_)-1
-}
= mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
- getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
+ let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
(returnFlt . CSequential) [
CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
- bpw1_code,
- CMachOpStmt res_c MO_Nat_Shr [t3, bpw1_t] Nothing
+ CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing
]
= mkTemp WordRep `thenFlt` \ w ->
(returnFlt . CSequential) [
CAssign w (mkDerefOff WordRep arg fixedHdrSize),
- CMachOpStmt w MO_NatU_Mul [w, CBytesPerWord] (Just vols),
+ CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols),
CAssign res w
]
mkClosureLabel,
mkSRTLabel,
+ mkSRTDescLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
data IdLabelInfo
= Closure -- Label for (static???) closure
| SRT -- Static reference table
+ | SRTDesc -- Static reference table descriptor
| InfoTbl -- Info tables for closures; always read-only
| Entry -- entry point
| Slow -- slow entry point
\begin{code}
mkClosureLabel id = IdLabel id Closure
mkSRTLabel id = IdLabel id SRT
+mkSRTDescLabel id = IdLabel id SRTDesc
mkInfoTableLabel id = IdLabel id InfoTbl
mkEntryLabel id = IdLabel id Entry
mkSlowEntryLabel id = IdLabel id Slow
-- don't bother declaring SRT & Bitmap labels, we always make sure
-- they are defined before use.
needsCDecl (IdLabel _ SRT) = False
+needsCDecl (IdLabel _ SRTDesc) = False
needsCDecl (IdLabel _ Bitmap) = False
needsCDecl (IdLabel _ _) = True
needsCDecl (CaseLabel _ CaseReturnPt) = True
info Info table
srt Static reference table
+ srtd Static reference table descriptor
entry Entry code
slow Slow entry code (if any)
ret Direct return address
(case x of
Closure -> ptext SLIT("closure")
SRT -> ptext SLIT("srt")
+ SRTDesc -> ptext SLIT("srtd")
InfoTbl -> ptext SLIT("info")
Entry -> ptext SLIT("entry")
Slow -> ptext SLIT("slow")
addOneToUniqSet, UniqSet
)
import StgSyn ( StgOp(..) )
-import BitSet ( BitSet, intBS )
import Outputable
import FastString
import Util ( lengthExceeds )
-import Constants ( wORD_SIZE )
#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
}
pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c
- = pp_liveness_switch liveness semi $
- hcat [ ptext SLIT("BITMAP"), lparen,
- pprCLabel lbl, comma,
- int size, comma,
- pp_bitmap mask, rparen ]
+ = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask)
+
+pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c
+ = pprWordArray desc_lbl (
+ CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) :
+ mkWordCLit (fromIntegral len) :
+ bitmapAddrModes bitmap
+ )
pprAbsC (CSimultaneous abs_c) c
= hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
rep = getAmodeRep item
pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
- = pprInfoTable info_lbl (mkInfoTable cl_info)
+ = pprWordArray info_lbl (mkInfoTable cl_info)
$$ let stuff = CCodeBlock entry_lbl entry in
pprAbsC stuff (costs stuff)
where
) $$ ptext SLIT("};")
pprAbsC stmt@(CRetDirect uniq code srt liveness) _
- = pprInfoTable info_lbl (mkRetInfoTable entry_lbl srt liveness)
+ = pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness)
$$ let stuff = CCodeBlock entry_lbl code in
pprAbsC stuff (costs stuff)
where
entry_lbl = mkReturnPtLabel uniq
pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
- = pprInfoTable lbl (mkVecInfoTable amodes srt liveness)
+ = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
= vcat [
ClosureInfo).
\begin{code}
-pprInfoTable info_lbl amodes
+pprWordArray lbl amodes
= (case snd (initTE (ppr_decls_Amodes amodes)) of
Just pp -> pp
Nothing -> empty)
- $$ hcat [ ppLocalness info_lbl, ptext SLIT("StgWord "),
- pprCLabel info_lbl, ptext SLIT("[] = {") ]
+ $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "),
+ pprCLabel lbl, ptext SLIT("[] = {") ]
$$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
$$ ptext SLIT("};")
amode has kind2.
\begin{code}
-ppr_amode CBytesPerWord
- = text "(sizeof(void*))"
-
ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
= case (pprRegRelative False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> panic "ppr_amode: CIndex"
cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE")
\end{code}
-\begin{code}
-\end{code}
-
%************************************************************************
%* *
\subsection[ppr-liveness-masks]{Liveness Masks}
%************************************************************************
\begin{code}
-pp_bitmap_switch :: Int -> SDoc -> SDoc -> SDoc
-pp_bitmap_switch size small large
- | size <= mAX_SMALL_BITMAP_SIZE = small
- | otherwise = large
-
--- magic numbers, must agree with BITMAP_BITS_SHIFT in InfoTables.h
-mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27
- | otherwise = 58
-
-pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc
-pp_liveness_switch (Liveness _ size _) = pp_bitmap_switch size
-
-pp_bitset :: BitSet -> SDoc
-pp_bitset s
- | i < -1 = int (i + 1) <> text "-1"
- | otherwise = int i
- where i = intBS s
-
-pp_bitmap :: [BitSet] -> SDoc
-pp_bitmap [] = int 0
-pp_bitmap ss = hcat (punctuate (ptext SLIT(" COMMA ")) (bundle ss)) where
- bundle [] = []
- bundle [s] = [hcat bitmap32]
- where bitmap32 = [ptext SLIT("BITMAP32"), lparen,
- pp_bitset s, rparen]
- bundle (s1:s2:ss) = hcat bitmap64 : bundle ss
- where bitmap64 = [ptext SLIT("BITMAP64"), lparen,
- pp_bitset s1, comma, pp_bitset s2, rparen]
+bitmapAddrModes [] = [mkWordCLit 0]
+bitmapAddrModes xs = map mkWordCLit xs
\end{code}
%************************************************************************
--- /dev/null
+--
+-- (c) The University of Glasgow 2003
+--
+
+-- Functions for constructing bitmaps, which are used in various
+-- places in generated code (stack frame liveness masks, function
+-- argument liveness masks, SRT bitmaps).
+
+module Bitmap (
+ Bitmap, mkBitmap,
+ intsToBitmap, intsToReverseBitmap,
+ mAX_SMALL_BITMAP_SIZE
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/MachDeps.h"
+
+import SMRep
+import Constants
+import DATA_BITS
+
+{-|
+A bitmap represented by a sequence of 'StgWord's on the /target/
+architecture. These are used for bitmaps in info tables and other
+generated code which need to be emitted as sequences of StgWords.
+-}
+type Bitmap = [StgWord]
+
+-- | Make a bitmap from a sequence of bits
+mkBitmap :: [Bool] -> Bitmap
+mkBitmap [] = []
+mkBitmap stuff = chunkToBitmap chunk : mkBitmap rest
+ where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
+
+chunkToBitmap :: [Bool] -> StgWord
+chunkToBitmap chunk =
+ foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
+
+-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.
+-- eg. @[1,2,4], size 4 ==> 0xb@.
+--
+-- The list of @Int@s /must/ be already sorted.
+intsToBitmap :: Int -> [Int] -> Bitmap
+intsToBitmap size slots{- must be sorted -}
+ | size <= 0 = []
+ | otherwise =
+ (foldr (.|.) 0 (map (1 `shiftL`) these)) :
+ intsToBitmap (size - wORD_SIZE_IN_BITS)
+ (map (\x -> x - wORD_SIZE_IN_BITS) rest)
+ where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
+
+-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
+-- eg. @[1,2,4], size 4 ==> 0x8@ (we leave any bits outside the size as zero,
+-- just to make the bitmap easier to read).
+--
+-- The list of @Int@s /must/ be already sorted.
+intsToReverseBitmap :: Int -> [Int] -> Bitmap
+intsToReverseBitmap size slots{- must be sorted -}
+ | size <= 0 = []
+ | otherwise =
+ (foldr xor init (map (1 `shiftL`) these)) :
+ intsToBitmap (size - wORD_SIZE_IN_BITS)
+ (map (\x -> x - wORD_SIZE_IN_BITS) rest)
+ where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
+ init
+ | size >= wORD_SIZE_IN_BITS = complement 0
+ | otherwise = (1 `shiftL` size) - 1
+
+{-|
+Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
+Some kinds of bitmap pack a size/bitmap into a single word if
+possible, or fall back to an external pointer when the bitmap is too
+large. This value represents the largest size of bitmap that can be
+packed into a single word.
+-}
+mAX_SMALL_BITMAP_SIZE :: Int
+mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27
+ | otherwise = 58
+
import CLabel ( mkClosureLabel,
mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-import BitSet
+import Bitmap
import PrimRep ( isFollowableRep, getPrimRepSize )
import Id ( Id, idPrimRep, idType )
import Type ( typePrimRep )
buildLivenessMask
:: VirtualSpOffset -- size of the stack frame
-> VirtualSpOffset -- offset from which the bitmap should start
- -> FCode LivenessMask -- mask for free/unlifted slots
+ -> FCode Bitmap -- mask for free/unlifted slots
buildLivenessMask size sp = do {
-- find all live stack-resident pointers
};
ASSERT(all (>=0) rel_slots)
- return (listToLivenessMask size rel_slots)
+ return (intsToReverseBitmap size rel_slots)
}
--- make a bitmap where the slots specified are the *zeros* in the bitmap.
--- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
-listToLivenessMask :: Int -> [Int] -> [BitSet]
-listToLivenessMask size slots{- must be sorted -}
- | size <= 0 = []
- | otherwise = init `minusBS` mkBS these :
- listToLivenessMask (size - 32) (map (\x -> x - 32) rest)
- where (these,rest) = span (<32) slots
- init
- | size >= 32 = all_ones
- | otherwise = mkBS [0..size-1]
-
- all_ones = mkBS [0..31]
-
-- In a continuation, we want a liveness mask that starts from just after
-- the return address, which is on the stack at realSp.
mask <- buildLivenessMask frame_size (realSp-1)
let liveness = Liveness (mkBitmapLabel name) frame_size mask
- absC (CBitmap liveness)
+ absC (maybeLargeBitmap liveness)
return liveness
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.61 2002/12/11 15:36:25 simonmar Exp $
+% $Id: CgCase.lhs,v 1.62 2003/05/14 09:13:53 simonmar Exp $
%
%********************************************************
%* *
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
-import Name ( getName )
+import Name ( Name, getName )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
import Util ( only )
cgEvalAlts cc_slot bndr srt alts
=
- let uniq = getUnique bndr in
+ let uniq = getUnique bndr; name = getName bndr in
- buildContLivenessMask (getName bndr) `thenFC` \ liveness ->
+ buildContLivenessMask name `thenFC` \ liveness ->
case alts of
lbl = mkReturnInfoLabel uniq
in
cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c ->
- getSRTInfo srt `thenFC` \ srt_info ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
returnFC (CaseAlts (CLbl lbl RetRep) Nothing False)
cgAlgAlts GCMayHappen (not is_alg) uniq cc_slot use_labelled_alts
alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
- mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness
+ mkReturnVector name tagged_alt_absCs deflt_absC srt liveness
ret_conv `thenFC` \ return_vec ->
returnFC (CaseAlts return_vec semi_tagged_stuff False)
getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
- getSRTInfo srt `thenFC` \srt_info ->
+ getSRTInfo name srt `thenFC` \srt_info ->
absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
srt_info liveness) `thenC`
mode for it.
\begin{code}
-mkReturnVector :: Unique
+mkReturnVector :: Name
-> [(ConTag, AbstractC)] -- Branch codes
-> AbstractC -- Default case
-> SRT -- continuation's SRT
-> CtrlReturnConvention
-> FCode CAddrMode
-mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
- = getSRTInfo srt `thenFC` \ srt_info ->
+mkReturnVector name tagged_alt_absCs deflt_absC srt liveness ret_conv
+ = getSRTInfo name srt `thenFC` \ srt_info ->
let
(return_vec_amode, vtbl_body) = case ret_conv of {
returnFC return_vec_amode
-- )
where
+ uniq = getUnique name
vtbl_label = mkVecTblLabel uniq
ret_label = mkReturnInfoLabel uniq
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.60 2003/05/14 09:13:53 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
cgTopRhsClosure id ccs binder_info srt args body lf_info
=
+ let
+ name = idName id
+ in
-- LAY OUT THE OBJECT
- getSRTInfo srt `thenFC` \ srt_info ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
moduleName `thenFC` \ mod_name ->
let
name = idName id
reduced_fvs = if binder_is_a_fv
then fvs `minusList` [binder]
else fvs
+
+ name = idName binder
in
mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
- getSRTInfo srt `thenFC` \ srt_info ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
moduleName `thenFC` \ mod_name ->
let
descr = closureDescription mod_name (idName binder)
--
(case closureFunInfo closure_info of
Just (_, ArgGen slow_lbl liveness) ->
- absC (CBitmap liveness) `thenC`
+ absC (maybeLargeBitmap liveness) `thenC`
absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
returnFC (mkRegSaveCode arg_regs arg_reps)
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
-> [StgArg] -- Args
- -> SRT
-> FCode (Id, CgIdInfo)
-cgTopRhsCon id con args srt
+cgTopRhsCon id con args
= ASSERT( not (isDllConApp con args) ) -- checks for litlit args too
ASSERT( args `lengthIs` dataConRepArity con )
closure_label = mkClosureLabel name
(closure_info, amodes_w_offsets)
= layOutStaticConstr con getAmodeRep amodes
+ caffy = any stgArgHasCafRefs args
in
-- BUILD THE OBJECT
closure_info
dontCareCCS -- because it's static data
(map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs
- (nonEmptySRT srt) -- has CAF refs
+ caffy -- has CAF refs
) `thenC`
-- NOTE: can't use idCafInfo instead of nonEmptySRT above,
-- because top-level constructors that were floated by
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.52 2002/12/11 15:36:26 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.53 2003/05/14 09:13:55 simonmar Exp $
%
%********************************************************
%* *
\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
\begin{code}
-cgExpr (StgLet (StgNonRec srt name rhs) expr)
- = cgRhs srt name rhs `thenFC` \ (name, info) ->
+cgExpr (StgLet (StgNonRec name rhs) expr)
+ = cgRhs name rhs `thenFC` \ (name, info) ->
addBindC name info `thenC`
cgExpr expr
-cgExpr (StgLet (StgRec srt pairs) expr)
+cgExpr (StgLet (StgRec pairs) expr)
= fixC (\ new_bindings -> addBindsC new_bindings `thenC`
- listFCs [ cgRhs srt b e | (b,e) <- pairs ]
+ listFCs [ cgRhs b e | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings `thenC`
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
-cgRhs srt name (StgRhsCon maybe_cc con args)
+cgRhs name (StgRhsCon maybe_cc con args)
= getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
returnFC (name, idinfo)
-cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
+cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
\end{code}
%********************************************************
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
- (StgNonRec srt binder rhs)
+ (StgNonRec binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive srt binder rhs
+ NonRecursive binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
- (StgRec srt pairs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
= fixC (\ new_bindings ->
addBindsC new_bindings `thenC`
listFCs [ cgLetNoEscapeRhs full_live_in_rhss
- rhs_eob_info maybe_cc_slot Recursive srt b e
+ rhs_eob_info maybe_cc_slot Recursive b e
| (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
-> EndOfBlockInfo
-> Maybe VirtualSpOffset
-> RecFlag
- -> SRT
-> Id
-> StgRhs
-> FCode (Id, CgIdInfo)
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
- (StgRhsClosure cc bi _ upd_flag args body)
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
+ (StgRhsClosure cc bi _ upd_flag srt args body)
= -- We could check the update flag, but currently we don't switch it off
-- for let-no-escaped things, so we omit the check too!
-- case upd_flag of
-- For a constructor RHS we want to generate a single chunk of code which
-- can be jumped to from many places, which will return the constructor.
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
+ = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
(StgConApp con args)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.19 2002/12/11 15:36:26 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.20 2003/05/14 09:13:56 simonmar Exp $
%
%********************************************************
%* *
import ClosureInfo ( mkLFLetNoEscape )
import CostCentre ( CostCentreStack )
import Name ( getName )
-import Id ( idPrimRep, Id )
+import Id ( Id, idPrimRep, idName )
import Var ( idUnique )
import PrimRep ( PrimRep(..), retPrimRepSize, isFollowableRep )
import BasicTypes ( RecFlag(..) )
buildContLivenessMask (getName binder) `thenFC` \ liveness ->
forkAbsC (cgLetNoEscapeBody binder cc args body uniq)
`thenFC` \ code ->
- getSRTInfo srt `thenFC` \ srt_info ->
+ getSRTInfo (idName binder) srt `thenFC` \ srt_info ->
absC (CRetDirect uniq code srt_info liveness)
`thenC` returnFC ())
`thenFC` \ (vSp, _) ->
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.37 2003/01/07 14:31:20 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.38 2003/05/14 09:13:56 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
import Module ( Module )
import DataCon ( ConTag )
import Id ( Id )
+import Name ( Name )
import VarEnv
import PrimRep ( PrimRep(..) )
+import SMRep ( StgHalfWord, hALF_WORD )
import FastString
import Outputable
the nested bindings via the monad.
\begin{code}
-getSRTInfo :: SRT -> FCode C_SRT
-getSRTInfo NoSRT = return NoC_SRT
-getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel
- return (C_SRT srt_lbl off len)
+getSRTInfo :: Name -> SRT -> FCode C_SRT
+getSRTInfo id NoSRT = return NoC_SRT
+getSRTInfo id (SRT off len bmp)
+ | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do
+ srt_lbl <- getSRTLabel
+ let srt_desc_lbl = mkSRTDescLabel id
+ absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp)
+ return (C_SRT srt_desc_lbl 0 srt_escape)
+ | otherwise = do
+ srt_lbl <- getSRTLabel
+ return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+
+srt_escape = (-1) :: StgHalfWord
getSRTLabel :: FCode CLabel -- Used only by cgPanic
getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
return srt_lbl
-setSRTLabel :: CLabel -> Code -> Code
+setSRTLabel :: CLabel -> FCode a -> FCode a
setSRTLabel srt_lbl code
= do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.36 2002/12/11 15:36:27 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.37 2003/05/14 09:13:56 simonmar Exp $
%
%********************************************************
%* *
-- Generate the right jump or return
(case sequel of
- UpdateCode -> -- Ha! We can go direct to the update code,
- -- (making sure to jump to the *correct* update
- -- code.)
- absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep)
- return_info)
-
CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so
-- we can go right to the alternative
-- it's the subject of a wad of special-case
-- code in cgReturnCon
- other -> -- OnStack, or (CaseAlts ret_amode Nothing)
+ other -> -- OnStack, or (CaseAlts ret_amode Nothing),
+ -- or UpdateCode.
sequelToAmode sequel `thenFC` \ ret_amode ->
absC (CReturn ret_amode return_info)
)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.56 2002/12/12 11:53:11 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.57 2003/05/14 09:13:56 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
import Outputable
import Literal
import Constants
-import BitSet
+import Bitmap
import Maybe ( isJust )
-import DATA_WORD
import DATA_BITS
\end{code}
argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
where bitmap = argBits reps
lbl = mkBitmapLabel name
- liveness = Liveness lbl (length bitmap)
- (map chunkToLiveness (mkChunks bitmap))
+ liveness = Liveness lbl (length bitmap) (mkBitmap bitmap)
argBits [] = []
argBits (rep : args)
| isFollowableRep rep = False : argBits args
| otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
-
-mkChunks [] = []
-mkChunks stuff = chunk : mkChunks rest
- where (chunk, rest) = splitAt 32 stuff
-
-chunkToLiveness chunk = mkBS [ n | (True,n) <- zip chunk [0..] ]
\end{code}
represented by a label+offset expression).
\begin{code}
-#if SIZEOF_HSWORD == 4
-type StgWord = Word32
-#define HALF_WORD 16
-#elif SIZEOF_HSWORD == 8
-type StgWord = Word64
-#define HALF_WORD 32
-#endif
-
mkInfoTable :: ClosureInfo -> [CAddrMode]
mkInfoTable cl_info
| opt_Unregisterised = std_info ++ extra_bits
is_con = isJust semi_tag
(srt_label,srt_len)
- | Just tag <- semi_tag = (mkIntCLit 0, tag) -- constructor
+ | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor
| otherwise =
case srt of
NoC_SRT -> (mkIntCLit 0, 0)
- C_SRT lbl off len ->
+ C_SRT lbl off bitmap ->
(CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
- len)
+ bitmap)
ptrs = closurePtrsSize cl_info
nptrs = size - ptrs
layout_info :: StgWord
#ifdef WORDS_BIGENDIAN
- layout_info = (fromIntegral ptrs `shiftL` HALF_WORD) .|. fromIntegral nptrs
+ layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs
#else
- layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` HALF_WORD)
+ layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD)
#endif
layout_amode = mkWordCLit layout_info
| otherwise = [fun_amode]
#ifdef WORDS_BIGENDIAN
- fun_desc = (fromIntegral fun_type `shiftL` HALF_WORD) .|. fromIntegral arity
+ fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity
#else
- fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` HALF_WORD)
-#endif
+ fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD)
+#endif
fun_amode = mkWordCLit fun_desc
cl_type srt_len liveness_amode
liveness_amode = livenessToAddrMode liveness
-
+
(srt_label,srt_len) =
case srt of
NoC_SRT -> (mkIntCLit 0, 0)
- C_SRT lbl off len ->
- (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
- len)
+ C_SRT lbl off bitmap ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ bitmap)
cl_type = case (null vector, isBigLiveness liveness) of
(True, True) -> rET_BIG
-> CAddrMode -- closure type descr (profiling)
-> CAddrMode -- closure descr (profiling)
-> Int -- closure type
- -> Int -- SRT length
+ -> StgHalfWord -- SRT length
-> CAddrMode -- layout field
-> [CAddrMode]
mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
-- ToDo: do this using .byte and .word directives.
type_info :: StgWord
#ifdef WORDS_BIGENDIAN
- type_info = (fromIntegral cl_type `shiftL` HALF_WORD) .|.
+ type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|.
(fromIntegral srt_len)
#else
type_info = (fromIntegral cl_type) .|.
- (fromIntegral srt_len `shiftL` HALF_WORD)
+ (fromIntegral srt_len `shiftL` hALF_WORD)
#endif
isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
small_bits = case bits of
[] -> 0
- [b] -> fromIntegral (intBS b)
+ [b] -> fromIntegral b
_ -> panic "livenessToAddrMode"
-mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
-
-mkWordCLit :: StgWord -> CAddrMode
-mkWordCLit wd = CLit (MachWord (fromIntegral wd))
-
zero_amode = mkIntCLit 0
\end{code}
import CgMonad
import AbsCSyn
import PrelNames ( gHC_PRIM )
-import CLabel ( CLabel, mkSRTLabel, mkClosureLabel,
+import CLabel ( mkSRTLabel, mkClosureLabel,
mkPlainModuleInitLabel, mkModuleInitLabel )
import PprAbsC ( dumpRealC )
import AbsCUtils ( mkAbstractCs, flattenAbsC )
import ClosureInfo ( mkClosureLFInfo )
import CmdLineOpts ( DynFlags, DynFlag(..),
opt_SccProfilingOn, opt_EnsureSplittableC )
-import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), TypeEnv,
- typeEnvTyCons )
+import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons )
import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
-> ForeignStubs
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
- -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
+ -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
codeGen dflags this_mod type_env foreign_stubs imported_mods
variable.
\begin{code}
-cgTopBinding :: (StgBinding,[Id]) -> Code
-cgTopBinding (StgNonRec srt_info id rhs, srt)
+cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code
+cgTopBinding (StgNonRec id rhs, srts)
= absC maybeSplitCode `thenC`
- maybeExternaliseId id `thenFC` \ id' ->
- let
- srt_label = mkSRTLabel (idName id')
- in
- mkSRT srt_label srt [] `thenC`
- setSRTLabel srt_label (
- cgTopRhs id' rhs srt_info `thenFC` \ (id, info) ->
- addBindC id info -- Add the un-externalised Id to the envt, so we
- -- find it when we look up occurrences
- )
-
-cgTopBinding (StgRec srt_info pairs, srt)
+ maybeExternaliseId id `thenFC` \ id' ->
+ mapM_ (mkSRT [id']) srts `thenC`
+ cgTopRhs id' rhs `thenFC` \ (id, info) ->
+ addBindC id info `thenC`
+ -- Add the un-externalised Id to the envt, so we
+ -- find it when we look up occurrences
+ nopC
+
+cgTopBinding (StgRec pairs, srts)
= absC maybeSplitCode `thenC`
let
(bndrs, rhss) = unzip pairs
in
- mapFCs maybeExternaliseId bndrs `thenFC` \ bndrs'@(id:_) ->
+ mapFCs maybeExternaliseId bndrs `thenFC` \ bndrs' ->
let
- srt_label = mkSRTLabel (idName id)
- pairs' = zip bndrs' rhss
+ pairs' = zip bndrs' rhss
in
- mkSRT srt_label srt bndrs' `thenC`
- setSRTLabel srt_label (
- fixC (\ new_binds ->
+ mapM_ (mkSRT bndrs') srts `thenC`
+ fixC (\ new_binds ->
addBindsC new_binds `thenC`
- mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
- ) `thenFC` \ new_binds -> nopC
- )
+ mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
+ ) `thenFC` \ new_binds ->
+ nopC
-mkSRT :: CLabel -> [Id] -> [Id] -> Code
-mkSRT lbl [] these = nopC
-mkSRT lbl ids these
+mkSRT :: [Id] -> (Id,[Id]) -> Code
+mkSRT these (id,[]) = nopC
+mkSRT these (id,ids)
= mapFCs remap ids `thenFC` \ ids ->
- absC (CSRT lbl (map (mkClosureLabel . idName) ids))
+ remap id `thenFC` \ id ->
+ absC (CSRT (mkSRTLabel (idName id)) (map (mkClosureLabel . idName) ids))
where
-- sigh, better map all the ids against the environment in case they've
-- been externalised (see maybeExternaliseId below).
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
-cgTopRhs bndr (StgRhsCon cc con args) srt
- = forkStatics (cgTopRhsCon bndr con args srt)
+cgTopRhs bndr (StgRhsCon cc con args)
+ = forkStatics (cgTopRhsCon bndr con args)
-cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
+cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
= ASSERT(null fvs) -- There should be no free variables
let
+ srt_label = mkSRTLabel (idName bndr)
lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
in
- forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
+ setSRTLabel srt_label $
+ forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
\end{code}
isStaticRep,
fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize,
stdItblSize, retItblSize,
- getSMRepClosureTypeInt
+ getSMRepClosureTypeInt,
- , rET_SMALL
- , rET_VEC_SMALL
- , rET_BIG
- , rET_VEC_BIG
+ rET_SMALL, rET_VEC_SMALL, rET_BIG, rET_VEC_BIG,
+ StgWord, StgHalfWord, hALF_WORD,
) where
#include "HsVersions.h"
+#include "../includes/MachDeps.h"
import CmdLineOpts
import Constants
import Outputable
+
+import DATA_WORD
\end{code}
%************************************************************************
rET_BIG = (RET_BIG :: Int)
rET_VEC_BIG = (RET_VEC_BIG :: Int)
\end{code}
+
+A type representing an StgWord on the target platform.
+
+\begin{code}
+#if SIZEOF_HSWORD == 4
+type StgWord = Word32
+type StgHalfWord = Word16
+hALF_WORD = 16 :: Int
+#elif SIZEOF_HSWORD == 8
+type StgWord = Word64
+type StgHalfWord = Word32
+hALF_WORD = 32 :: Int
+#else
+#error unknown SIZEOF_HSWORD
+#endif
+\end{code}
import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep )
import Constants ( wORD_SIZE )
import FastString ( FastString(..), unpackFS )
+import SMRep ( StgWord )
import FiniteMap
import Outputable
import FastString ( FastString(..), unpackFS )
import Panic ( GhcException(..) )
import PprType ( pprType )
-import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
+import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
+import Bitmap ( intsToReverseBitmap, mkBitmap )
import OrdList
import Constants ( wORD_SIZE )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel )
| isFollowableRep rep = False : argBits args
| otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
-mkBitmap :: [Bool] -> [StgWord]
-mkBitmap [] = []
-mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest
- where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
-
-chunkToLiveness :: [Bool] -> StgWord
-chunkToLiveness chunk =
- foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
-
--- make a bitmap where the slots specified are the *zeros* in the bitmap.
--- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
-intsToBitmap :: Int -> [Int] -> [StgWord]
-intsToBitmap size slots{- must be sorted -}
- | size <= 0 = []
- | otherwise =
- (foldr xor init (map (1 `shiftL`) these)) :
- intsToBitmap (size - wORD_SIZE_IN_BITS)
- (map (\x -> x - wORD_SIZE_IN_BITS) rest)
- where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
- init
- | size >= wORD_SIZE_IN_BITS = complement 0
- | otherwise = (1 `shiftL` size) - 1
-
-wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int
-
-- -----------------------------------------------------------------------------
-- schemeTopBind
-- things that are pointers, whereas in CgBindery the code builds the
-- bitmap from the free slots and unboxed bindings.
-- (ToDo: merge?)
- bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots)
+ bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots)
where
binds = fmToList p
rel_slots = concat (map spread binds)
\begin{code}
module ByteCodeInstr (
- BCInstr(..), ProtoBCO(..), StgWord, bciStackUse
+ BCInstr(..), ProtoBCO(..), bciStackUse
) where
#include "HsVersions.h"
-#include "MachDeps.h"
+#include "../includes/MachDeps.h"
import Outputable
import Name ( Name )
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
+import SMRep ( StgWord )
import GHC.Ptr
-import Data.Word
-
-- ----------------------------------------------------------------------------
-- Bytecode instructions
--- The appropriate StgWord type for this platform (needed for bitmaps)
-#if SIZEOF_HSWORD == 4
-type StgWord = Word32
-#else
-type StgWord = Word64
-#endif
-
data ProtoBCO a
= ProtoBCO {
protoBCOName :: a, -- name, in some sense
wORD64_SIZE,
wORD_SIZE,
+ wORD_SIZE_IN_BITS,
bLOCK_SIZE,
bLOCK_SIZE_W,
\begin{code}
wORD_SIZE = (SIZEOF_HSWORD :: Int)
+wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int
\end{code}
Size of a storage manager block (in bytes).
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
-import BitSet ( BitSet, intBS )
-- DEBUGGING ONLY
--import TRACE ( trace )
gentopcode stmt@(CStaticClosure lbl closure_info _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs (
- if opt_Static
- then StSegment DataSegment
- : StLabel lbl : code []
- else StSegment DataSegment
- : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
- : StLabel lbl : code []
- )
+ returnUs ( StSegment DataSegment
+ : StLabel lbl : code []
+ )
gentopcode stmt@(CRetVector lbl amodes srt liveness)
= returnUs ( StSegment TextSegment
= StCLbl label
gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
- | isBigLiveness l
= returnUs
[ StSegment TextSegment
, StLabel lbl
- , StData WordRep (map StInt (toInteger size : bitmapToIntegers mask))
+ , StData WordRep (map StInt (toInteger size : map toInteger mask))
+ ]
+
+ gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap)
+ = returnUs
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (
+ StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) :
+ map StInt (toInteger len : map toInteger bitmap)
+ )
]
- | otherwise
- = returnUs []
- where
- -- ToDo: translate out bitmaps earlier, like info tables
- isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
- mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
%---------------------------------------------------------------------------
-\begin{code}
-bitmapToIntegers :: [BitSet] -> [Integer]
-bitmapToIntegers = bundle . map (toInteger . intBS)
- where
-#if BYTES_PER_WORD == 4
- bundle = id
-#else
- bundle [] = []
- bundle is = case splitAt (BYTES_PER_WORD/4) is of
- (these, those) ->
- ( foldr1 (\x y -> x + 4294967296 * y)
- [x `mod` 4294967296 | x <- these]
- : bundle those
- )
-#endif
-\end{code}
-
-%---------------------------------------------------------------------------
-
This answers the question: Can the code fall through to the next
line(s) of code? This errs towards saying True if it can't choose,
because it is used for eliminating needless jumps. In other words, if
amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
-amodeToStix CBytesPerWord
- = StInt (toInteger wORD_SIZE)
-
amodeToStix (CAddr (SpRel off))
= StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
import StgSyn
import Id ( Id )
import VarSet
-import BasicTypes ( TopLevelFlag(..), isTopLevel )
-import Util ( mapAccumL )
+import VarEnv
+import Util ( sortLt )
+import Maybes ( orElse )
+import Maybes ( expectJust )
+import Bitmap ( intsToBitmap )
#ifdef DEBUG
-import Util ( lengthIs )
import Outputable
#endif
-\end{code}
-\begin{code}
-computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
- -- The incoming bindingd are filled with SRTEntries in their SRT slots
- -- the outgoing ones have NoSRT/SRT values instead
+import List
-computeSRTs binds = map srtTopBind binds
+import Util
+import Outputable
\end{code}
------------------------------------------------------------------------------
-Algorithm for figuring out SRT layout.
-
-Our functions have type
-
-srtExpr :: SrtOffset -- Next free offset within the SRT
- -> StgExpr -- Expression to analyse
- -> (StgExpr, -- (e) newly annotated expression
- SrtIds, -- (s) SRT required for this expression (reversed)
- SrtOffset) -- (o) new offset
-
-We build a single SRT for a recursive binding group, which is why the
-SRT building is done at the binding level rather than the
-StgRhsClosure level.
-
-The SRT is built up in reverse order, to avoid too many expensive
-appends. We therefore reverse the SRT before returning it, so that
-the offsets will be from the beginning of the SRT.
-
------------------------------------------------------------------------------
-Top-level Bindings
-
-A function whose CafInfo is NoCafRefs will have an empty SRT, and its
-closure will not appear in the SRT of any other function (unless we're
-compiling without optimisation and the CafInfos haven't been emitted
-in the interface files).
-
-Top-Level recursive groups
-
-This gets a bit complicated, but the general idea is that we want a
-single SRT for the whole group, and we'd rather not have recursive
-references in it if at all possible.
-
-We collect all the global references for the group, and filter out
-those that are binders in the group and not CAFs themselves. Why is
-it done this way?
-
- - if all the bindings in the group just refer to each other,
- and none of them are CAFs, we'd like to get an empty SRT.
-
- - if any of the bindings in the group refer to a CAF, this will
- appear in the SRT.
-
-Hmm, that probably makes no sense.
-
\begin{code}
-type SrtOffset = Int
-type SrtIds = [Id] -- An *reverse-ordered* list of the Ids needed in the SRT
-
-srtTopBind :: StgBinding -> (StgBinding, SrtIds)
-
-srtTopBind bind
- = srtBind TopLevel 0 bind =: \ (bind', srt, off) ->
- if isConBind bind'
- then (bind', []) -- Don't need an SRT for a static constructor
- else (bind', reverse srt) -- The 'reverse' is because the SRT is
- -- built up reversed, for efficiency's sake
+computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
+ -- The incoming bindingd are filled with SRTEntries in their SRT slots
+ -- the outgoing ones have NoSRT/SRT values instead
-isConBind (StgNonRec _ _ r) = isConRhs r
-isConBind (StgRec _ bs) = all isConRhs (map snd bs)
+computeSRTs binds = srtTopBinds emptyVarEnv binds
-isConRhs (StgRhsCon _ _ _) = True
-isConRhs _ = False
+-- --------------------------------------------------------------------------
+-- Top-level Bindings
-srtBind :: TopLevelFlag -> SrtOffset -> StgBinding
- -> (StgBinding, SrtIds, SrtOffset)
+srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
-srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs)
- = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
+srtTopBinds env [] = []
+srtTopBinds env (StgNonRec b rhs : binds) =
+ (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
where
- (new_rhs, rhs_srt, rhs_off) = srtRhs off rhs
- (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off
-
-
-srtBind top off (StgRec (SRTEntries rhss_cafs) pairs)
- = (StgRec srt_info new_pairs, this_srt, body_off)
+ (rhs', srt) = srtTopRhs b rhs
+ env' = maybeExtendEnv env b rhs
+ srt' = applyEnvList env srt
+srtTopBinds env (StgRec bs : binds) =
+ (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
+ where
+ (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
+ bndrs = map fst bs
+ srts' = map (applyEnvList env) srts
+
+-- Shorting out indirections in SRTs: if a binding has an SRT with a single
+-- element in it, we just inline it with that element everywhere it occurs
+-- in other SRTs.
+--
+-- This is in a way a generalisation of the CafInfo. CafInfo says
+-- whether a top-level binding has *zero* CAF references, allowing us
+-- to omit it from SRTs. Here, we pick up bindings with *one* CAF
+-- reference, and inline its SRT everywhere it occurs. We could pass
+-- this information across module boundaries too, but we currently
+-- don't.
+
+maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
+ | [one] <- varSetElems cafs
+ = extendVarEnv env bndr (applyEnv env one)
+maybeExtendEnv env bndr _ = env
+
+applyEnvList :: IdEnv Id -> [Id] -> [Id]
+applyEnvList env = map (applyEnv env)
+
+applyEnv env id = lookupVarEnv env id `orElse` id
+
+-- ---- Top-level right hand sides:
+
+srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
+
+srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
+srtTopRhs binder rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _)
+ = (srtRhs table rhs, elems)
where
- ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
+ elems = varSetElems cafs
+ table = mkVarEnv (zip elems [0..])
- do_bind (off,srt) (bndr,rhs)
- = srtRhs off rhs =: \(rhs', srt', off') ->
- ((off', srt'++srt), (bndr, rhs'))
+-- ---- Binds:
- non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ]
+srtBind :: IdEnv Int -> StgBinding -> StgBinding
- filtered_rhss_cafs
- | isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs
- | otherwise = rhss_cafs
+srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
+srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
- (srt_info, this_srt, body_off)
- = constructSRT filtered_rhss_cafs rhss_srt off rhss_off
+-- ---- Right Hand Sides:
-caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True
-caf_rhs _ = False
-\end{code}
+srtRhs :: IdEnv Int -> StgRhs -> StgRhs
------------------------------------------------------------------------------
-Right Hand Sides
+srtRhs table e@(StgRhsCon cc con args) = e
+srtRhs table (StgRhsClosure cc bi free_vars u (SRTEntries cafs) args body)
+ = StgRhsClosure cc bi free_vars u (constructSRT table cafs) args
+ $! (srtExpr table body)
-\begin{code}
-srtRhs :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
+-- ---------------------------------------------------------------------------
+-- Expressions
-srtRhs off (StgRhsClosure cc bi free_vars u args body)
- = srtExpr off body =: \(body, srt, off) ->
- (StgRhsClosure cc bi free_vars u args body, srt, off)
+srtExpr :: IdEnv Int -> StgExpr -> StgExpr
-srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
-\end{code}
+srtExpr table e@(StgApp f args) = e
+srtExpr table e@(StgLit l) = e
+srtExpr table e@(StgConApp con args) = e
+srtExpr table e@(StgOpApp op args ty) = e
------------------------------------------------------------------------------
-Expressions
+srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
-\begin{code}
-srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
-
-srtExpr off e@(StgApp f args) = (e, [], off)
-srtExpr off e@(StgLit l) = (e, [], off)
-srtExpr off e@(StgConApp con args) = (e, [], off)
-srtExpr off e@(StgOpApp op args ty) = (e, [], off)
-
-srtExpr off (StgSCC cc expr) =
- srtExpr off expr =: \(expr, srt, off) ->
- (StgSCC cc expr, srt, off)
-
-srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
- = srtCaseAlts off alts =: \(alts, alts_srt, alts_off) ->
- let
- (srt_info, this_srt, scrut_off)
- = constructSRT cafs_in_alts alts_srt off alts_off
+srtExpr table (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
+ = let
+ expr' = srtExpr table scrut
+ srt_info = constructSRT table cafs_in_alts
+ alts' = srtCaseAlts table alts
in
- srtExpr scrut_off scrut =: \(scrut, scrut_srt, case_off) ->
+ StgCase expr' live1 live2 uniq srt_info alts'
- (StgCase scrut live1 live2 uniq srt_info alts,
- scrut_srt ++ this_srt,
- case_off)
-
-srtExpr off (StgLet bind body)
- = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
- srtExpr body_off body =: \ (body', expr_srt, let_off) ->
- (StgLet bind' body', expr_srt ++ bind_srt, let_off)
+srtExpr table (StgLet bind body)
+ = srtBind table bind =: \ bind' ->
+ srtExpr table body =: \ body' ->
+ StgLet bind' body'
-srtExpr off (StgLetNoEscape live1 live2 bind body)
- = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
- srtExpr body_off body =: \ (body', expr_srt, let_off) ->
- (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off)
+srtExpr table (StgLetNoEscape live1 live2 bind body)
+ = srtBind table bind =: \ bind' ->
+ srtExpr table body =: \ body' ->
+ StgLetNoEscape live1 live2 bind' body'
#ifdef DEBUG
-srtExpr off expr = pprPanic "srtExpr" (ppr expr)
+srtExpr table expr = pprPanic "srtExpr" (ppr expr)
#endif
-\end{code}
------------------------------------------------------------------------------
-Construct an SRT.
-Construct the SRT at this point from its sub-SRTs and any new global
-references which aren't already contained in one of the sub-SRTs (and
-which are "live").
+-- Case Alternatives
-\begin{code}
-constructSRT caf_refs sub_srt initial_offset current_offset
- = let
- extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs)
- this_srt = extra_refs ++ sub_srt
+srtCaseAlts :: IdEnv Int -> StgCaseAlts -> StgCaseAlts
- -- Add the length of the new entries to the
- -- current offset to get the next free offset in the global SRT.
- new_offset = current_offset + length extra_refs
- srt_length = new_offset - initial_offset
+srtCaseAlts table (StgAlgAlts t alts dflt)
+ = (StgAlgAlts t $! map (srtAlgAlt table) alts) $! srtDefault table dflt
- srt_info | srt_length == 0 = NoSRT
- | otherwise = SRT initial_offset srt_length
+srtCaseAlts table (StgPrimAlts t alts dflt)
+ = (StgPrimAlts t $! map (srtPrimAlt table) alts) $! srtDefault table dflt
- in ASSERT( this_srt `lengthIs` srt_length )
- (srt_info, this_srt, new_offset)
-\end{code}
+srtAlgAlt table (con,args,used,rhs)
+ = (,,,) con args used $! srtExpr table rhs
------------------------------------------------------------------------------
-Case Alternatives
+srtPrimAlt table (lit,rhs)
+ = (,) lit $! srtExpr table rhs
-\begin{code}
-srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset)
-
-srtCaseAlts off (StgAlgAlts t alts dflt)
- = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
- mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
- (StgAlgAlts t alts' dflt', alts_srt, alts_off)
-
-srtCaseAlts off (StgPrimAlts t alts dflt)
- = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
- mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
- (StgPrimAlts t alts' dflt', alts_srt, alts_off)
-
-srtAlgAlt (off,srt) (con,args,used,rhs)
- = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
- ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs'))
-
-srtPrimAlt (off,srt) (lit,rhs)
- = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
- ((rhs_off, rhs_srt ++ srt), (lit, rhs'))
-
-srtDefault off StgNoDefault
- = ((off,[]), StgNoDefault)
-srtDefault off (StgBindDefault rhs)
- = srtExpr off rhs =: \(rhs', srt, off) ->
- ((off,srt), StgBindDefault rhs')
-\end{code}
+srtDefault table StgNoDefault = StgNoDefault
+srtDefault table (StgBindDefault rhs)
+ = StgBindDefault $! srtExpr table rhs
-----------------------------------------------------------------------------
-Misc stuff
+-- Construct an SRT bitmap.
+
+constructSRT :: IdEnv Int -> IdSet -> SRT
+constructSRT table entries
+ | isEmptyVarSet entries = NoSRT
+ | otherwise = SRT offset len bitmap
+ where
+ ints = map (expectJust "constructSRT" . lookupVarEnv table)
+ (varSetElems entries)
+ sorted_ints = sortLt (<) ints
+ offset = head sorted_ints
+ bitmap_entries = map (subtract offset) sorted_ints
+ len = last bitmap_entries + 1
+ bitmap = intsToBitmap len bitmap_entries
+
+-- ---------------------------------------------------------------------------
+-- Misc stuff
-\begin{code}
a =: k = k a
+
\end{code}
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
-> Module -- module name (profiling only)
-> [StgBinding] -- input...
- -> IO ( [(StgBinding,[Id])] -- output program...
+ -> IO ( [(StgBinding,[(Id,[Id])])] -- output program...
, CollectedCCs) -- cost centre information (declared and used)
stg2stg dflags module_name binds
-> StgBinding
-> StatEnv
-statBinding top (StgNonRec _srt b rhs)
+statBinding top (StgNonRec b rhs)
= statRhs top (b, rhs)
-statBinding top (StgRec _srt pairs)
+statBinding top (StgRec pairs)
= combineSEs (map (statRhs top) pairs)
statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (b, StgRhsCon cc con args)
= countOne (ConstructorBinds top)
-statRhs top (b, StgRhsClosure cc bi fv u args body)
+statRhs top (b, StgRhsClosure cc bi fv u _srt args body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet (manifestArity rhs)
- (stg_rhs, fvs', lv_info) =
+ (stg_rhs, fvs') =
initLne env (
coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
- freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
- returnLne (stg_rhs, fvs', lv_info)
+ returnLne (stg_rhs, fvs')
)
- bind = StgNonRec (mkSRT lv_info) id stg_rhs
+ bind = StgNonRec id stg_rhs
in
ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
ASSERT2(consistentCafInfo id bind, ppr id)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
- (stg_rhss, fvs', lv_info)
+ (stg_rhss, fvs')
= initLne env' (
mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
- freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
- returnLne (stg_rhss, fvs', lv_info)
+ returnLne (stg_rhss, fvs')
)
- bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
+ bind = StgRec (zip binders stg_rhss)
in
ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
coreToTopStgRhs scope_fv_info (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
- returnLne (mkTopStgRhs upd rhs_fvs bndr_info new_rhs, rhs_fvs)
+ freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
+ returnLne (mkTopStgRhs upd rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
upd | rhsIsNonUpd rhs = SingleEntry
| otherwise = Updatable
-mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs
+mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
+ -> StgRhs
-mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body)
+mkTopStgRhs upd rhs_fvs srt binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
+ srt
bndrs body
-mkTopStgRhs upd rhs_fvs binder_info (StgConApp con args)
+mkTopStgRhs upd rhs_fvs srt binder_info (StgConApp con args)
| not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp)
= StgRhsCon noCCS con args
-mkTopStgRhs upd rhs_fvs binder_info rhs
+mkTopStgRhs upd rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
upd
+ srt
[] rhs
\end{code}
vars_bind body_fvs (NonRec binder rhs)
- = coreToStgRhs body_fvs (binder,rhs)
- `thenLne` \ (rhs2, bind_fvs, escs) ->
-
- freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info ->
+ = coreToStgRhs body_fvs [] (binder,rhs)
+ `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
let
env_ext_item = mk_binding bind_lv_info binder rhs
in
- returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2,
+ returnLne (StgNonRec binder rhs2,
bind_fvs, escs, bind_lv_info, [env_ext_item])
| (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext (
- mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs) pairs
- `thenLne` \ (rhss2, fvss, escss) ->
+ mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
+ `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
let
bind_fvs = unionFVInfos fvss
+ bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
escs = unionVarSets escss
in
- freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
- `thenLne` \ bind_lv_info ->
-
- returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2),
+ returnLne (StgRec (binders `zip` rhss2),
bind_fvs, escs, bind_lv_info, env_ext)
)
)
\begin{code}
coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
+ -> [Id]
-> (Id,CoreExpr)
- -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
+ -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
-coreToStgRhs scope_fv_info (bndr, rhs)
+coreToStgRhs scope_fv_info binders (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
getEnvLne `thenLne` \ env ->
- returnLne (mkStgRhs env rhs_fvs bndr_info new_rhs,
- rhs_fvs, rhs_escs)
+ freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
+ returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
+ rhs_fvs, lv_info, rhs_escs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
-mkStgRhs :: IdEnv HowBound -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs env rhs_fvs binder_info (StgConApp con args)
+mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
= StgRhsCon noCCS con args
-mkStgRhs env rhs_fvs binder_info (StgLam _ bndrs body)
+mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
- bndrs body
+ srt bndrs body
-mkStgRhs env rhs_fvs binder_info rhs
+mkStgRhs rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
- upd_flag [] rhs
+ upd_flag srt [] rhs
where
upd_flag = Updatable
{-
mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
returnLne (r1:rs1, r2:rs2, r3:rs3)
+mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
+
+mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
+mapAndUnzip4Lne f (x:xs)
+ = f x `thenLne` \ (r1, r2, r3, r4) ->
+ mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
+ returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
+
fixLne :: (a -> LneM a) -> LneM a
fixLne expr env lvs_cont
= result
\begin{code}
lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
-lintStgBinds (StgNonRec _srt binder rhs)
+lintStgBinds (StgNonRec binder rhs)
= lint_binds_help (binder,rhs) `thenL_`
returnL [binder]
-lintStgBinds (StgRec _srt pairs)
+lintStgBinds (StgRec pairs)
= addInScopeVars binders (
mapL lint_binds_help pairs `thenL_`
returnL binders
\begin{code}
lintStgRhs :: StgRhs -> LintM (Maybe Type)
-lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
= lintStgExpr expr
-lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) (
addInScopeVars binders (
lintStgExpr expr `thenMaybeL` \ body_ty ->
SRT(..), noSRT, nonEmptySRT,
-- utils
- stgBindHasCafRefs, stgRhsArity, getArgPrimRep,
+ stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, getArgPrimRep,
isLitLitArg, isDllConApp, isStgTypeArg,
stgArgType, stgBinders,
import CostCentre ( CostCentreStack, CostCentre )
import VarSet ( IdSet, isEmptyVarSet )
import Var ( isId )
-import Id ( Id, idName, idPrimRep, idType )
+import Id ( Id, idName, idPrimRep, idType, idCafInfo )
+import IdInfo ( mayHaveCafRefs )
import Name ( isDllName )
import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
import ForeignCall ( ForeignCall )
import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Unique ( Unique )
+import Bitmap
import CmdLineOpts ( opt_SccProfilingOn )
\end{code}
\begin{code}
data GenStgBinding bndr occ
- = StgNonRec SRT bndr (GenStgRhs bndr occ)
- | StgRec SRT [(bndr, GenStgRhs bndr occ)]
+ = StgNonRec bndr (GenStgRhs bndr occ)
+ | StgRec [(bndr, GenStgRhs bndr occ)]
stgBinders :: GenStgBinding bndr occ -> [bndr]
-stgBinders (StgNonRec _ b _) = [b]
-stgBinders (StgRec _ bs) = map fst bs
+stgBinders (StgNonRec b _) = [b]
+stgBinders (StgRec bs) = map fst bs
\end{code}
%************************************************************************
[occ] -- non-global free vars; a list, rather than
-- a set, because order is important
!UpdateFlag -- ReEntrant | Updatable | SingleEntry
+ SRT -- The SRT reference
[bndr] -- arguments; if empty, then not a function;
-- as above, order is important.
(GenStgExpr bndr occ) -- body
\begin{code}
stgRhsArity :: StgRhs -> Int
-stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) = count isId bndrs
+stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = count isId bndrs
-- The arity never includes type parameters, so
-- when keeping type arguments and binders in the Stg syntax
-- (opt_RuntimeTypes) we have to fliter out the type binders.
\end{code}
\begin{code}
-stgBindHasCafRefs :: GenStgBinding bndr occ -> Bool
-stgBindHasCafRefs (StgNonRec srt _ rhs)
- = nonEmptySRT srt || rhsIsUpdatable rhs
-stgBindHasCafRefs (StgRec srt binds)
- = nonEmptySRT srt || any rhsIsUpdatable (map snd binds)
-
-rhsIsUpdatable (StgRhsClosure _ _ _ upd _ _) = isUpdatable upd
-rhsIsUpdatable _ = False
+stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
+stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
+stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
+
+rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
+ = isUpdatable upd || nonEmptySRT srt
+rhsHasCafRefs (StgRhsCon _ _ args)
+ = any stgArgHasCafRefs args
+
+stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
+stgArgHasCafRefs _ = False
\end{code}
Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
data SRT = NoSRT
- | SRTEntries IdSet -- generated by CoreToStg
- | SRT !Int{-offset-} !Int{-length-} -- generated by computeSRTs
+ | SRTEntries IdSet
+ -- generated by CoreToStg
+ | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
+ -- generated by computeSRTs
noSRT :: SRT
noSRT = NoSRT
pprSRT (NoSRT) = ptext SLIT("_no_srt_")
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
-pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
+pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*")
\end{code}
%************************************************************************
pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
=> GenStgBinding bndr bdee -> SDoc
-pprGenStgBinding (StgNonRec srt bndr rhs)
- = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals])
- 4 ((<>) (ppr rhs) semi)
+pprGenStgBinding (StgNonRec bndr rhs)
+ = hang (hsep [ppr bndr, equals])
+ 4 ((<>) (ppr rhs) semi)
-pprGenStgBinding (StgRec srt pairs)
+pprGenStgBinding (StgRec pairs)
= vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
- pprMaybeSRT srt :
(map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
where
ppr_bind (bndr, expr)
pprGenStgBindingWithSRT
:: (Outputable bndr, Outputable bdee, Ord bdee)
- => (GenStgBinding bndr bdee,[Id]) -> SDoc
+ => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
-pprGenStgBindingWithSRT (bind,srt)
- = vcat [ pprGenStgBinding bind,
- ptext SLIT("SRT: ") <> ppr srt ]
+pprGenStgBindingWithSRT (bind,srts)
+ = vcat (pprGenStgBinding bind : map pprSRT srts)
+ where pprSRT (id,srt) =
+ ptext SLIT("SRT") <> parens (ppr id) <> ptext SLIT(": ") <> ppr srt
-pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
+pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
\end{code}
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
= hcat [ ppr cc,
pp_binder_info bi,
brackets (ifPprDebug (ppr free_var)),
- ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
+ ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ]
-- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
= hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
pp_binder_info bi,
ifPprDebug (brackets (interppSP free_vars)),
- char '\\' <> ppr upd_flag, brackets (interppSP args)])
+ char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
4 (ppr body)
pprStgRhs (StgRhsCon cc con args)
space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
pprMaybeSRT (NoSRT) = empty
-pprMaybeSRT srt = ptext SLIT("srt: ") <> pprSRT srt
+pprMaybeSRT srt = ptext SLIT("srt:") <> pprSRT srt
\end{code}
|| /^${T_US}.*_slow${T_POST_LBL}$/o # slow entry
|| /^${T_US}__stginit.*${T_POST_LBL}$/o # __stginit<module>
|| /^${T_US}.*_btm${T_POST_LBL}$/o # large bitmaps
+ || /^${T_US}.*_srtd${T_POST_LBL}$/o # large bitmaps
|| /^${T_US}.*_fast${T_POST_LBL}$/o # primops
|| /^${T_US}.*_closure_tbl${T_POST_LBL}$/o # closure tables
|| /^_uname:/o; # x86/Solaris2
/* ----------------------------------------------------------------------------
- * $Id: ClosureMacros.h,v 1.35 2002/12/11 15:36:37 simonmar Exp $
+ * $Id: ClosureMacros.h,v 1.36 2003/05/14 09:14:01 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
-------------------------------------------------------------------------- */
/* constructors don't have SRTs */
-#define GET_TAG(info) (INFO_PTR_TO_STRUCT(info)->srt_len)
+#define GET_TAG(info) (INFO_PTR_TO_STRUCT(info)->srt_bitmap)
#endif /* CLOSUREMACROS_H */
/* ----------------------------------------------------------------------------
- * $Id: InfoMacros.h,v 1.21 2002/12/11 15:36:37 simonmar Exp $
+ * $Id: InfoMacros.h,v 1.22 2003/05/14 09:14:01 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
#ifndef INFOMACROS_H
#define INFOMACROS_H
-#define STD_INFO(srt_len_, type_) \
- srt_len : srt_len_, \
+#define STD_INFO(srt_bitmap_, type_) \
+ srt_bitmap : srt_bitmap_, \
type : type_
#define THUNK_INFO(srt_, srt_off_) \
INFO_TABLE_THUNK(info, /* info-table label */ \
entry, /* entry code label */ \
ptrs, nptrs, /* closure layout info */\
- srt_, srt_off_, srt_len_, /* SRT info */ \
+ srt_, srt_off_, srt_bitmap_, /* SRT info */ \
type, /* closure type */ \
info_class, entry_class, /* C storage classes */ \
prof_descr, prof_type) /* profiling info */ \
info_class const StgInfoTable stg_RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
+ SRT_INFO(RBH,srt_,srt_off_,srt_bitmap_), \
INCLUDE_RBH_INFO(info), \
INIT_ENTRY(stg_RBH_##entry) \
} ; \
info_class const StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
+ SRT_INFO(type,srt_,srt_off_,srt_bitmap_), \
INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry) \
}
INFO_TABLE_THUNK(info, /* info-table label */ \
entry, /* entry code label */ \
ptrs, nptrs, /* closure layout info */\
- srt_, srt_off_, srt_len_, /* SRT info */ \
+ srt_, srt_off_, srt_bitmap_, /* SRT info */ \
type_, /* closure type */ \
info_class, entry_class, /* C storage classes */ \
prof_descr, prof_type) /* profiling info */ \
i : { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
- STD_INFO(srt_len_, type_), \
+ STD_INFO(srt_bitmap_, type_), \
INIT_ENTRY(entry) \
}, \
THUNK_INFO(srt_,srt_off_), \
#if defined(GRAN) || defined(PAR)
#define \
-INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
+INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_bitmap_, \
type, info_class, entry_class, \
prof_descr, prof_type) \
entry_class(stg_RBH_##entry); \
info_class const StgInfoTable stg_RBH_##info = { \
layout : { bitmap : (StgWord)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
+ SRT_INFO(RBH,srt_,srt_off_,srt_bitmap_), \
INCLUDE_RBH_INFO(info), \
INIT_ENTRY(stg_RBH_##entry) \
}; \
info_class const StgInfoTable info = { \
layout : { bitmap : (StgWord)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
+ SRT_INFO(type,srt_,srt_off_,srt_bitmap_), \
INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry) \
}
#else
#define \
-INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
+INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_bitmap_, \
type_, info_class, entry_class, \
prof_descr, prof_type) \
entry_class(entry); \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
- STD_INFO(srt_len_,type_), \
+ STD_INFO(srt_bitmap_,type_), \
INIT_ENTRY(entry) \
}, \
RET_INFO(srt_,srt_off_) \
INIT_ENTRY(entry) \
}
-#define constrTag(con) (get_itbl(con)->srt_len)
+#define constrTag(con) (get_itbl(con)->srt_bitmap)
/* function info table -----------------------------------------------------*/
INFO_TABLE_FUN_GEN(info, /* info-table label */ \
entry, /* entry code label */ \
ptrs, nptrs, /* closure layout info */\
- srt_, srt_off_, srt_len_, /* SRT info */ \
+ srt_, srt_off_, srt_bitmap_, /* SRT info */ \
fun_type_, arity_, bitmap_, slow_apply_, \
/* Function info */ \
type_, /* closure type */ \
i : { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
- STD_INFO(srt_len_,type_), \
+ STD_INFO(srt_bitmap_,type_), \
INIT_ENTRY(entry) \
}, \
srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \
StgRetInfoTable i;
} vec_info_8;
-#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2) \
info_class const vec_info_2 info = { \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3 \
) \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4 \
) \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7, alt_8 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
StgFunPtr vec[8];
} vec_info_8;
-#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2) \
info_class const vec_info_2 info = { \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
} \
}
-#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3 \
) \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3 } \
}
-#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4 \
) \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3, alt_4 } \
}
-#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
}, \
alt_5 } \
}
-#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
}, \
alt_5, alt_6 } \
}
-#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
}, \
alt_5, alt_6, alt_7 } \
}
-#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_len_, \
+#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7, alt_8 \
i : { \
i : { \
layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_,type_) \
+ STD_INFO(srt_bitmap_,type_) \
}, \
RET_INFO(srt_,srt_off_) \
}, \
#ifndef TABLES_NEXT_TO_CODE
#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
- srt_, srt_off_, srt_len_, \
+ srt_, srt_off_, srt_bitmap_, \
type_, info_class, entry_class \
) \
info_class const vec_info_8 nm##_info = { \
i : { \
layout : { \
bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_, type_), \
+ STD_INFO(srt_bitmap_, type_), \
INIT_ENTRY(nm##_ret) \
}, \
RET_INFO(srt_,srt_off_) \
#else
#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
- srt_, srt_off_, srt_len_, \
+ srt_, srt_off_, srt_bitmap_, \
type_, info_class, entry_class \
) \
info_class const vec_info_8 nm##_info = { \
i : { \
layout : { \
bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_len_, type_), \
+ STD_INFO(srt_bitmap_, type_), \
INIT_ENTRY(nm##_ret) \
}, \
RET_INFO(srt_,srt_off_) \
#define SRT(lbl) \
static const StgSRT lbl = {
-#define BITMAP(lbl,size,contents) \
- static const StgLargeBitmap lbl = { size, { contents } };
-
-#if SIZEOF_VOID_P == 8
-#define BITMAP64(first, second) \
- (((StgWord32)(first)) | ((StgWord)(StgWord32)(second) << 32))
-#else
-#define BITMAP64(first, second) first, second
-#endif
-#define BITMAP32(x) ((StgWord32)(x))
-#define COMMA ,
-
/* DLL_SRT_ENTRY is used on the Win32 side when filling initialising
an entry in an SRT table with a reference to a closure that's
living in a DLL. See elsewhere for reasons as to why we need
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.28 2002/12/11 15:36:37 simonmar Exp $
+ * $Id: InfoTables.h,v 1.29 2003/05/14 09:14:02 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
StgWord bitmap[FLEXIBLE_ARRAY];
} StgLargeBitmap;
+/* -----------------------------------------------------------------------------
+ SRTs (Static Reference Tables)
+
+ These tables are used to keep track of the static objects referred
+ to by the code for a closure or stack frame, so that we can follow
+ static data references from code and thus accurately
+ garbage-collect CAFs.
+ -------------------------------------------------------------------------- */
+
+// An SRT is just an array of closure pointers:
+typedef StgClosure* StgSRT[];
+
+// Each info table refers to some subset of the closure pointers in an
+// SRT. It does this using a pair of an StgSRT pointer and a
+// half-word bitmap. If the half-word bitmap isn't large enough, then
+// we fall back to a large SRT, including an unbounded bitmap. If the
+// half-word bitmap is set to all ones (0xffff), then the StgSRT
+// pointer instead points to an StgLargeSRT:
+typedef struct StgLargeSRT_ {
+ StgSRT *srt;
+ StgLargeBitmap l;
+} StgLargeSRT;
+
/* ----------------------------------------------------------------------------
Info Tables
------------------------------------------------------------------------- */
//
-// An SRT.
-//
-typedef StgClosure* StgSRT[];
-
-//
// The "standard" part of an info table. Every info table has this bit.
//
typedef struct _StgInfoTable {
StgClosureInfo layout; // closure layout info (one word)
StgHalfWord type; // closure type
- StgHalfWord srt_len; // number of entries in SRT (or constructor tag)
+ StgHalfWord srt_bitmap; // number of entries in SRT (or constructor tag)
#ifdef TABLES_NEXT_TO_CODE
StgCode code[FLEXIBLE_ARRAY];
and bitmap fields may be left out (they are at the end, so omitting
them doesn't affect the layout).
- - If srt_len (in the std info table part) is zero, then the srt
+ - If srt_bitmap (in the std info table part) is zero, then the srt
field may be omitted. This only applies if the slow_apply and
bitmap fields have also been omitted.
-------------------------------------------------------------------------- */
-------------------------------------------------------------------------- */
// When info tables are laid out backwards, we can omit the SRT
-// pointer iff srt_len is zero.
+// pointer iff srt_bitmap is zero.
typedef struct _StgRetInfoTable {
#if !defined(TABLES_NEXT_TO_CODE)
-------------------------------------------------------------------------- */
// When info tables are laid out backwards, we can omit the SRT
-// pointer iff srt_len is zero.
+// pointer iff srt_bitmap is zero.
typedef struct _StgThunkInfoTable {
#if !defined(TABLES_NEXT_TO_CODE)
/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.26 2002/12/11 15:36:42 simonmar Exp $
+ * $Id: Exception.hc,v 1.27 2003/05/14 09:13:59 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
VEC_POLY_INFO_TABLE(stg_catch_frame, \
MK_SMALL_BITMAP(CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP), \
- NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME,, EF_);
+ NULL/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, CATCH_FRAME,, EF_);
/* -----------------------------------------------------------------------------
* The catch infotable
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.154 2003/04/22 16:25:09 simonmar Exp $
+ * $Id: GC.c,v 1.155 2003/05/14 09:13:59 simonmar Exp $
*
* (c) The GHC Team 1998-2003
*
if M < evac_gen set failed_to_evac flag to indicate that we
didn't manage to evacuate this object into evac_gen.
+
+ OPTIMISATION NOTES:
+
+ evacuate() is the single most important function performance-wise
+ in the GC. Various things have been tried to speed it up, but as
+ far as I can tell the code generated by gcc 3.2 with -O2 is about
+ as good as it's going to get. We pass the argument to evacuate()
+ in a register using the 'regparm' attribute (see the prototype for
+ evacuate() near the top of this file).
+
+ Changing evacuate() to take an (StgClosure **) rather than
+ returning the new pointer seems attractive, because we can avoid
+ writing back the pointer when it hasn't changed (eg. for a static
+ object, or an object in a generation > N). However, I tried it and
+ it doesn't help. One reason is that the (StgClosure **) pointer
+ gets spilled to the stack inside evacuate(), resulting in far more
+ extra reads/writes than we save.
-------------------------------------------------------------------------- */
static StgClosure *
goto loop;
case THUNK_STATIC:
- if (info->srt_len > 0 && major_gc &&
+ if (info->srt_bitmap != 0 && major_gc &&
THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
static_objects = (StgClosure *)q;
return q;
case FUN_STATIC:
- if (info->srt_len > 0 && major_gc &&
+ if (info->srt_bitmap != 0 && major_gc &&
FUN_STATIC_LINK((StgClosure *)q) == NULL) {
FUN_STATIC_LINK((StgClosure *)q) = static_objects;
static_objects = (StgClosure *)q;
dest->sp = (StgPtr)dest->sp + diff;
}
-/* evacuate the SRT. If srt_len is zero, then there isn't an
+/* Similar to scavenge_large_bitmap(), but we don't write back the
+ * pointers we get back from evacuate().
+ */
+static void
+scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
+{
+ nat i, b, size;
+ StgWord bitmap;
+ StgClosure **p;
+
+ b = 0;
+ bitmap = large_srt->l.bitmap[b];
+ size = (nat)large_srt->l.size;
+ p = large_srt->srt;
+ for (i = 0; i < size; ) {
+ if ((bitmap & 1) != 0) {
+ evacuate(*p);
+ }
+ i++;
+ p++;
+ if (i % BITS_IN(W_) == 0) {
+ b++;
+ bitmap = large_srt->l.bitmap[b];
+ } else {
+ bitmap = bitmap >> 1;
+ }
+ }
+}
+
+/* evacuate the SRT. If srt_bitmap is zero, then there isn't an
* srt field in the info table. That's ok, because we'll
* never dereference it.
*/
static inline void
-scavenge_srt (StgClosure **srt, nat srt_len)
+scavenge_srt (StgClosure **srt, nat srt_bitmap)
{
- StgClosure **srt_end;
+ nat bitmap;
+ StgClosure **p;
- srt_end = srt + srt_len;
+ bitmap = srt_bitmap;
+ p = srt;
- for (; srt < srt_end; srt++) {
- /* Special-case to handle references to closures hiding out in DLLs, since
- double indirections required to get at those. The code generator knows
- which is which when generating the SRT, so it stores the (indirect)
- reference to the DLL closure in the table by first adding one to it.
- We check for this here, and undo the addition before evacuating it.
+ if (bitmap == (StgHalfWord)(-1)) {
+ scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
+ return;
+ }
- If the SRT entry hasn't got bit 0 set, the SRT entry points to a
- closure that's fixed at link-time, and no extra magic is required.
- */
+ while (bitmap != 0) {
+ if ((bitmap & 1) != 0) {
#ifdef ENABLE_WIN32_DLL_SUPPORT
- if ( (unsigned long)(*srt) & 0x1 ) {
- evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
- } else {
- evacuate(*srt);
- }
+ // Special-case to handle references to closures hiding out in DLLs, since
+ // double indirections required to get at those. The code generator knows
+ // which is which when generating the SRT, so it stores the (indirect)
+ // reference to the DLL closure in the table by first adding one to it.
+ // We check for this here, and undo the addition before evacuating it.
+ //
+ // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
+ // closure that's fixed at link-time, and no extra magic is required.
+ if ( (unsigned long)(*srt) & 0x1 ) {
+ evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
+ } else {
+ evacuate(*p);
+ }
#else
- evacuate(*srt);
+ evacuate(*p);
#endif
+ }
+ p++;
+ bitmap = bitmap >> 1;
}
}
StgThunkInfoTable *thunk_info;
thunk_info = itbl_to_thunk_itbl(info);
- scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_len);
+ scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap);
}
static inline void
StgFunInfoTable *fun_info;
fun_info = itbl_to_fun_itbl(info);
- scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_len);
+ scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap);
}
static inline void
StgRetInfoTable *ret_info;
ret_info = itbl_to_ret_itbl(info);
- scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_len);
+ scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap);
}
/* -----------------------------------------------------------------------------
q = p;
switch (info->type) {
-
+
case MVAR:
/* treat MVars specially, because we don't want to evacuate the
* mut_link field in the middle of the closure.
p = scavenge_small_bitmap(p, size, bitmap);
follow_srt:
- scavenge_srt((StgClosure **)info->srt, info->i.srt_len);
+ scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap);
continue;
case RET_BCO: {
/* -----------------------------------------------------------------------------
- * $Id: HeapStackCheck.hc,v 1.30 2003/04/22 16:25:10 simonmar Exp $
+ * $Id: HeapStackCheck.hc,v 1.31 2003/05/14 09:13:59 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
INFO_TABLE_RET( stg_enter_info, stg_enter_ret,
MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_enter_ret)
{
INFO_TABLE_RET( stg_gc_void_info, stg_gc_void_ret,
MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_void_ret)
INFO_TABLE_RET( stg_gc_unpt_r1_info, stg_gc_unpt_r1_ret,
MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_unpt_r1_ret)
INFO_TABLE_RET( stg_gc_unbx_r1_info, stg_gc_unbx_r1_ret,
MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
/* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
INFO_TABLE_RET( stg_gc_f1_info, stg_gc_f1_ret,
MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_f1_ret)
INFO_TABLE_RET( stg_gc_d1_info, stg_gc_d1_ret,
MK_SMALL_BITMAP(DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_d1_ret)
INFO_TABLE_RET( stg_gc_l1_info, stg_gc_l1_ret,
MK_SMALL_BITMAP(LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_l1_ret)
INFO_TABLE_RET( stg_ut_1_0_unreg_info, stg_ut_1_0_unreg_ret,
MK_SMALL_BITMAP(1/*size*/, 0/*BITMAP*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_ut_1_0_unreg_ret)
INFO_TABLE_RET( stg_gc_fun_info,stg_gc_fun_ret,
MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_FUN,, EF_, 0, 0);
EXTFUN(stg_gc_fun_ret)
INFO_TABLE_RET( stg_gc_gen_info, stg_gc_gen_ret,
0/*bitmap*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_DYN,, EF_, 0, 0);
/* bitmap in the above info table is unused, the real one is on the stack.
INFO_TABLE_RET( stg_block_takemvar_info, stg_block_takemvar_ret,
MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, IF_, 0, 0);
IF_(stg_block_takemvar_ret)
INFO_TABLE_RET( stg_block_putmvar_info, stg_block_putmvar_ret,
MK_SMALL_BITMAP(2/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, IF_, 0, 0);
IF_(stg_block_putmvar_ret)
#ifdef mingw32_TARGET_OS
INFO_TABLE_RET( stg_block_async_info, stg_block_async_ret,
MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, IF_, 0, 0);
IF_(stg_block_async_ret)
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.59 2003/04/22 16:25:12 simonmar Exp $
+ * $Id: Printer.c,v 1.60 2003/05/14 09:13:59 simonmar Exp $
*
* (c) The GHC Team, 1994-2000.
*
#else
fprintf(stderr,"CONSTR(");
printPtr((StgPtr)obj->header.info);
- fprintf(stderr,"(tag=%d)",info->srt_len);
+ fprintf(stderr,"(tag=%d)",info->srt_bitmap);
#endif
for (i = 0; i < info->layout.payload.ptrs; ++i) {
fprintf(stderr,", ");
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.84 2003/03/27 13:54:32 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.85 2003/05/14 09:14:00 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_7_ret);
VEC_POLY_INFO_TABLE( stg_ctoi_ret_R1p, 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/,
RET_BCO,, EF_);
// When the returned value is a pointer, but unlifted, in R1 ...
INFO_TABLE_RET( stg_ctoi_ret_R1unpt_info, stg_ctoi_ret_R1unpt_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_ctoi_ret_R1unpt_entry)
{
FB_
// When the returned value is a non-pointer in R1 ...
INFO_TABLE_RET( stg_ctoi_ret_R1n_info, stg_ctoi_ret_R1n_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_ctoi_ret_R1n_entry)
{
FB_
// When the returned value is in F1 ...
INFO_TABLE_RET( stg_ctoi_ret_F1_info, stg_ctoi_ret_F1_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_ctoi_ret_F1_entry)
{
FB_
// When the returned value is in D1 ...
INFO_TABLE_RET( stg_ctoi_ret_D1_info, stg_ctoi_ret_D1_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_ctoi_ret_D1_entry)
{
FB_
// When the returned value is in L1 ...
INFO_TABLE_RET( stg_ctoi_ret_L1_info, stg_ctoi_ret_L1_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_ctoi_ret_L1_entry)
{
FB_
// When the returned value a VoidRep ...
INFO_TABLE_RET( stg_ctoi_ret_V_info, stg_ctoi_ret_V_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_ctoi_ret_V_entry)
{
FB_
// should apply the BCO on the stack to its arguments, also on the stack.
INFO_TABLE_RET( stg_apply_interp_info, stg_apply_interp_entry,
0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
IF_(stg_apply_interp_entry)
{
FB_
/* -----------------------------------------------------------------------------
- * $Id: StgStartup.hc,v 1.20 2002/12/11 15:36:54 simonmar Exp $
+ * $Id: StgStartup.hc,v 1.21 2003/05/14 09:14:00 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
INFO_TABLE_RET( stg_forceIO_info,stg_forceIO_ret,
MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
#ifdef REG_R1
INFO_TABLE_RET( stg_noforceIO_info,stg_noforceIO_ret,
MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
RET_SMALL,, EF_, 0, 0);
#ifdef REG_R1
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.39 2003/03/27 13:54:32 simonmar Exp $
+ * $Id: Updates.hc,v 1.40 2003/05/14 09:14:00 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
VEC_POLY_INFO_TABLE( stg_upd_frame,
MK_SMALL_BITMAP(UPD_FRAME_WORDS, UPD_FRAME_BITMAP),
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/,
UPDATE_FRAME,, EF_);
/*-----------------------------------------------------------------------------
VEC_POLY_INFO_TABLE( stg_seq_frame,
MK_SMALL_BITMAP(0, 0),
- 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/,
RET_SMALL,, EF_);
IF_(stg_seq_frame_ret)
projects / ghc-hetmet.git / commitdiff