Commit b0f4c44e authored by ian@well-typed.com's avatar ian@well-typed.com

Move tAG_BITS into platformConstants

parent 7ecefb6b
......@@ -72,7 +72,6 @@ import CLabel
import Outputable
import Unique
import UniqSupply
import Constants( tAG_MASK )
import DynFlags
import Util
......@@ -343,8 +342,8 @@ hasNoGlobalRegs _ = False
-- Tag bits mask
--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
cmmTagMask dflags = mkIntExpr dflags tAG_MASK
cmmPointerMask dflags = mkIntExpr dflags (complement tAG_MASK)
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
......
......@@ -87,8 +87,8 @@ data CgIdInfo
, cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode
}
mkCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo
mkCgIdInfo id vol stb lf
mkCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo
mkCgIdInfo dflags id vol stb lf
= CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
where
......@@ -100,10 +100,10 @@ mkCgIdInfo id vol stb lf
If yes, we assume that the constructor is evaluated and can
be tagged.
-}
= tagForCon con
= tagForCon dflags con
| otherwise
= funTagLFInfo lf
= funTagLFInfo dflags lf
voidIdInfo :: Id -> CgIdInfo
voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
......@@ -120,11 +120,11 @@ data VolatileLoc -- These locations die across a call
-- NB. Byte offset, because we subtract R1's
-- tag from the offset.
mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon
mkTaggedCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon
-> CgIdInfo
mkTaggedCgIdInfo id vol stb lf con
mkTaggedCgIdInfo dflags id vol stb lf con
= CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con }
cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon dflags con }
\end{code}
@StableLoc@ encodes where an Id can be found, used by
......@@ -172,36 +172,38 @@ instance Outputable StableLoc where
%************************************************************************
\begin{code}
stableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo
stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
stableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo
stableIdInfo dflags id amode lf_info = mkCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info
heapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo
heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
heapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo
heapIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info
letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
letNoEscapeIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
letNoEscapeIdInfo dflags id sp lf_info
= mkCgIdInfo dflags id NoVolatileLoc (VirStkLNE sp) lf_info
stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
stackIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
stackIdInfo dflags id sp lf_info
= mkCgIdInfo dflags id NoVolatileLoc (VirStkLoc sp) lf_info
nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo
nodeIdInfo dflags id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info
nodeIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info
regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo
regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
regIdInfo :: DynFlags -> Id -> CmmReg -> LambdaFormInfo -> CgIdInfo
regIdInfo dflags id reg lf_info = mkCgIdInfo dflags id (RegLoc reg) NoStableLoc lf_info
taggedStableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo
taggedStableIdInfo id amode lf_info con
= mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con
taggedStableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo
taggedStableIdInfo dflags id amode lf_info con
= mkTaggedCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info con
taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon
taggedHeapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon
-> CgIdInfo
taggedHeapIdInfo id offset lf_info con
= mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con
taggedHeapIdInfo dflags id offset lf_info con
= mkTaggedCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info con
untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo
untagNodeIdInfo dflags id offset lf_info tag
= mkCgIdInfo id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info
= mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info
idInfoToAmode :: CgIdInfo -> FCode CmmExpr
......@@ -283,7 +285,8 @@ modifyBindC name mangle_fn = do
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo id
= do { -- Try local bindings first
= do { dflags <- getDynFlags
; -- Try local bindings first
; local_binds <- getBinds
; case lookupVarEnv local_binds id of {
Just info -> return info ;
......@@ -301,7 +304,7 @@ getCgIdInfo id
in
if isExternalName name then do
let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id))
return (stableIdInfo id ext_lbl (mkLFImported id))
return (stableIdInfo dflags id ext_lbl (mkLFImported id))
else
if isVoidArg (idCgRep id) then
-- Void things are never in the environment
......@@ -428,9 +431,9 @@ getArgAmodes (atom:atoms)
\begin{code}
bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
bindArgsToStack args
= mapCs bind args
where
bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
= do dflags <- getDynFlags
let bind (id, offset) = addBindC id (stackIdInfo dflags id offset (mkLFArgument id))
mapCs bind args
bindArgsToRegs :: [(Id, GlobalReg)] -> Code
bindArgsToRegs args
......@@ -458,14 +461,14 @@ bindNewToTemp id
temp_reg = LocalReg uniq (argMachRep dflags (idCgRep id))
lf_info = mkLFArgument id -- Always used of things we
-- know nothing about
addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
addBindC id (regIdInfo dflags id (CmmLocal temp_reg) lf_info)
return temp_reg
bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
bindNewToReg name reg lf_info
= addBindC name info
where
info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
= do dflags <- getDynFlags
let info = mkCgIdInfo dflags name (RegLoc reg) NoStableLoc lf_info
addBindC name info
rebindToStack :: Id -> VirtualSpOffset -> Code
rebindToStack name offset
......
......@@ -84,7 +84,7 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do
; let descr = closureDescription dflags mod_name name
closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr
closure_label = mkLocalClosureLabel name $ idCafInfo id
cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
cg_id_info = stableIdInfo dflags id (mkLblExpr closure_label) lf_info
closure_rep = mkStaticClosureFields dflags closure_info ccs True []
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
......@@ -136,7 +136,7 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload
; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets
-- RETURN
; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) }
\end{code}
Here's the general case.
......@@ -188,7 +188,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
let
-- A function closure pointer may be tagged, so we
-- must take it into account when accessing the free variables.
mbtag = tagForArity (length args)
mbtag = tagForArity dflags (length args)
bind_fv (info, offset)
| Just tag <- mbtag
= bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
......@@ -211,7 +211,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets
-- RETURN
; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) }
mkClosureLFInfo :: Id -- The binder
......@@ -324,7 +324,7 @@ mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
; tickyEnterFun cl_info
; enterCostCentreFun cc
(CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg
, mkIntExpr dflags (funTag cl_info) ])
, mkIntExpr dflags (funTag dflags cl_info) ])
(node : map snd reg_args) -- live regs
; cgExpr body }
......
......@@ -98,7 +98,7 @@ cgTopRhsCon id con args
; emitDataLits closure_label closure_rep
-- RETURN
; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) }
; returnFC (id, taggedStableIdInfo dflags id (mkLblExpr closure_label) lf_info con) }
\end{code}
%************************************************************************
......@@ -148,8 +148,8 @@ which have exclusively size-zero (VoidRep) args, we generate no code
at all.
\begin{code}
buildDynCon' _ _ binder _ con []
= returnFC (taggedStableIdInfo binder
buildDynCon' dflags _ binder _ con []
= returnFC (taggedStableIdInfo dflags binder
(mkLblExpr (mkClosureLabel (dataConName con)
(idCafInfo binder)))
(mkConLFInfo con)
......@@ -193,7 +193,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
-- INTLIKE closures consist of a header and one word payload
intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW)
; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) }
; returnFC (taggedStableIdInfo dflags binder intlike_amode (mkConLFInfo con) con) }
buildDynCon' dflags platform binder _ con [arg_amode]
| maybeCharLikeCon con
......@@ -205,7 +205,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW)
; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) }
; returnFC (taggedStableIdInfo dflags binder charlike_amode (mkConLFInfo con) con) }
\end{code}
......@@ -218,7 +218,7 @@ buildDynCon' dflags _ binder ccs con args
(closure_info, amodes_w_offsets) = layOutDynConstr dflags con args
; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
; returnFC (taggedHeapIdInfo binder hp_off lf_info con) }
; returnFC (taggedHeapIdInfo dflags binder hp_off lf_info con) }
where
lf_info = mkConLFInfo con
......@@ -249,7 +249,7 @@ bindConArgs con args
let
-- The binding below forces the masking out of the tag bits
-- when accessing the constructor field.
bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con)
bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon dflags con)
(_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args)
--
ASSERT(not (isUnboxedTupleCon con)) return ()
......@@ -418,7 +418,8 @@ closures predeclared.
\begin{code}
cgTyCon :: TyCon -> FCode CmmGroup -- each constructor gets a separate CmmGroup
cgTyCon tycon
= do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
= do { dflags <- getDynFlags
; constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
-- Generate a table of static closures for an enumeration type
-- Put the table after the data constructor decls, because the
......@@ -431,7 +432,7 @@ cgTyCon tycon
; extra <-
if isEnumerationTyCon tycon then do
tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
[ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con)
[ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con)
| con <- tyConDataCons tycon])
return [tbl]
else
......
......@@ -217,7 +217,7 @@ emitAlgReturnTarget name branches mb_deflt fam_sz
= do { blks <- getCgStmts $ do
-- is the constructor tag in the node reg?
dflags <- getDynFlags
if isSmallFamily fam_sz
if isSmallFamily dflags fam_sz
then do -- yes, node has constr. tag
let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg)
branches' = [(tag+1,branch)|(tag,branch)<-branches]
......
......@@ -162,7 +162,8 @@ cgLetNoEscapeClosure
in
-- saveVolatileVarsAndRegs done earlier in cgExpr.
do { (vSp, _) <- forkEvalHelp rhs_eob_info
do { dflags <- getDynFlags
; (vSp, _) <- forkEvalHelp rhs_eob_info
(do { allocStackTop retAddrSizeW
; nukeDeadBindings full_live_in_rhss })
......@@ -176,7 +177,7 @@ cgLetNoEscapeClosure
; _ <- emitReturnTarget (idName bndr) abs_c
; return () })
; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
; returnFC (bndr, letNoEscapeIdInfo dflags bndr vSp lf_info) }
\end{code}
\begin{code}
......
......@@ -285,8 +285,8 @@ ldvRecordCreate closure = do dflags <- getDynFlags
ldvEnterClosure :: ClosureInfo -> Code
ldvEnterClosure closure_info
= do dflags <- getDynFlags
let tag = funTag dflags closure_info
ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
where tag = funTag closure_info
-- don't forget to substract node's tag
ldvEnter :: CmmExpr -> Code
......
......@@ -53,7 +53,6 @@ import TyCon
import DataCon
import Id
import IdInfo
import Constants
import SMRep
import OldCmm
import OldCmmUtils
......@@ -142,20 +141,20 @@ mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLi
Big families only use the tag value 1 to represent
evaluatedness.
-}
isSmallFamily :: Int -> Bool
isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
isSmallFamily :: DynFlags -> Int -> Bool
isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
tagForCon :: DataCon -> ConTagZ
tagForCon con = tag
tagForCon :: DynFlags -> DataCon -> ConTagZ
tagForCon dflags con = tag
where
con_tag = dataConTagZ con
fam_size = tyConFamilySize (dataConTyCon con)
tag | isSmallFamily fam_size = con_tag + 1
| otherwise = 1
tag | isSmallFamily dflags fam_size = con_tag + 1
| otherwise = 1
--Tag an expression, to do: refactor, this appears in some other module.
tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr
tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon con)
tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con)
--------------------------------------------------------------------------
--
......
......@@ -927,25 +927,27 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
funTag :: ClosureInfo -> Int
funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info
funTag _ = 0
funTag :: DynFlags -> ClosureInfo -> Int
funTag dflags (ClosureInfo { closureLFInfo = lf_info })
= funTagLFInfo dflags lf_info
funTag _ _ = 0
-- maybe this should do constructor tags too?
funTagLFInfo :: LambdaFormInfo -> Int
funTagLFInfo lf
funTagLFInfo :: DynFlags -> LambdaFormInfo -> Int
funTagLFInfo dflags lf
-- A function is tagged with its arity
| Just (arity,_) <- lfFunInfo lf,
Just tag <- tagForArity arity
Just tag <- tagForArity dflags arity
= tag
-- other closures (and unknown ones) are not tagged
| otherwise
= 0
tagForArity :: RepArity -> Maybe Int
tagForArity i | i <= mAX_PTR_TAG = Just i
| otherwise = Nothing
tagForArity :: DynFlags -> RepArity -> Maybe Int
tagForArity dflags i
| i <= mAX_PTR_TAG dflags = Just i
| otherwise = Nothing
clHasCafRefs :: ClosureInfo -> CafInfo
clHasCafRefs (ClosureInfo {closureSRT = srt}) =
......
......@@ -205,9 +205,10 @@ mkModuleInit cost_centre_info this_mod hpc_info
cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon tycon
= emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
= do dflags <- getDynFlags
emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
[ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
(tagForCon con)
(tagForCon dflags con)
| con <- tyConDataCons tycon]
......@@ -236,7 +237,7 @@ cgDataCon data_con
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_things)
; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg)
(tagForCon data_con)]
(tagForCon dflags data_con)]
}
-- The case continuation code expects a tagged pointer
......
......@@ -459,7 +459,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
; enterCostCentreFun cc
(CmmMachOp (mo_wordSub dflags)
[ CmmReg nodeReg
, mkIntExpr dflags (funTag cl_info) ])
, mkIntExpr dflags (funTag dflags cl_info) ])
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
......@@ -482,8 +482,8 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
load_fvs node lf_info = mapM_ (\ (reg, off) ->
do dflags <- getDynFlags
let tag = lfDynTag dflags lf_info
emit $ mkTaggedObjectLoad dflags reg node off tag)
where tag = lfDynTag lf_info
-----------------------------------------
-- The "slow entry" code for a function. This entry point takes its
......
......@@ -86,7 +86,6 @@ import TcType
import TyCon
import BasicTypes
import Outputable
import Constants
import DynFlags
import Util
......@@ -299,32 +298,33 @@ Big families only use the tag value 1 to represent evaluatedness.
We don't have very many tag bits: for example, we have 2 bits on
x86-32 and 3 bits on x86-64. -}
isSmallFamily :: Int -> Bool
isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
isSmallFamily :: DynFlags -> Int -> Bool
isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
-- We keep the *zero-indexed* tag in the srt_len field of the info
-- table of a data constructor.
dataConTagZ :: DataCon -> ConTagZ
dataConTagZ con = dataConTag con - fIRST_TAG
tagForCon :: DataCon -> DynTag
tagForCon con
| isSmallFamily fam_size = con_tag + 1
| otherwise = 1
tagForCon :: DynFlags -> DataCon -> DynTag
tagForCon dflags con
| isSmallFamily dflags fam_size = con_tag + 1
| otherwise = 1
where
con_tag = dataConTagZ con
fam_size = tyConFamilySize (dataConTyCon con)
tagForArity :: RepArity -> DynTag
tagForArity arity | isSmallFamily arity = arity
| otherwise = 0
tagForArity :: DynFlags -> RepArity -> DynTag
tagForArity dflags arity
| isSmallFamily dflags arity = arity
| otherwise = 0
lfDynTag :: LambdaFormInfo -> DynTag
lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
-- Return the tag in the low order bits of a variable bound
-- to this LambdaForm
lfDynTag (LFCon con) = tagForCon con
lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
lfDynTag _other = 0
lfDynTag dflags (LFCon con) = tagForCon dflags con
lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity
lfDynTag _ _other = 0
-----------------------------------------------------------------------------
......@@ -755,8 +755,9 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
funTag :: ClosureInfo -> DynTag
funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
funTag :: DynFlags -> ClosureInfo -> DynTag
funTag dflags (ClosureInfo { closureLFInfo = lf_info })
= lfDynTag dflags lf_info
isToplevClosure :: ClosureInfo -> Bool
isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
......
......@@ -246,17 +246,15 @@ bindConArgs (DataAlt con) base args
= ASSERT(not (isUnboxedTupleCon con))
do dflags <- getDynFlags
let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
tag = tagForCon dflags con
-- The binding below forces the masking out of the tag bits
-- when accessing the constructor field.
bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
bind_arg (arg, offset)
= do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
bindArgToReg arg
mapM bind_arg args_w_offsets
where
tag = tagForCon con
-- The binding below forces the masking out of the tag bits
-- when accessing the constructor field.
bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
bind_arg (arg, offset)
= do { dflags <- getDynFlags
; emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
; bindArgToReg arg }
bindConArgs _other_con _base args
= ASSERT( null args ) return []
......
......@@ -76,11 +76,11 @@ nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
-- Manipulating CgIdInfo
-------------------------------------
mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo id lf expr
mkCgIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo dflags id lf expr
= CgIdInfo { cg_id = id, cg_lf = lf
, cg_loc = CmmLoc expr,
cg_tag = lfDynTag lf }
cg_tag = lfDynTag dflags lf }
litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo dflags id lf lit
......@@ -88,13 +88,13 @@ litIdInfo dflags id lf lit
, cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag)
, cg_tag = tag }
where
tag = lfDynTag lf
tag = lfDynTag dflags lf
lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
lneIdInfo dflags id regs
= CgIdInfo { cg_id = id, cg_lf = lf
, cg_loc = LneLoc blk_id (map (idToReg dflags) regs)
, cg_tag = lfDynTag lf }
, cg_tag = lfDynTag dflags lf }
where
lf = mkLFLetNoEscape
blk_id = mkBlockId (idUnique id)
......@@ -104,11 +104,11 @@ rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo id lf_info
= do dflags <- getDynFlags
reg <- newTemp (gcWord dflags)
return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
return (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)), reg)
mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit dflags reg lf_info expr
= mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag lf_info))
= mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
idInfoToAmode :: CgIdInfo -> CmmExpr
-- Returns a CmmExpr for the *tagged* pointer
......@@ -217,7 +217,7 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg nvid@(NonVoid id) lf_info
= do dflags <- getDynFlags
let reg = idToReg dflags nvid
addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
addBindC id (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)))
return reg
rebindToReg :: NonVoid Id -> FCode LocalReg
......
......@@ -512,7 +512,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
bndr_reg = CmmLocal (idToReg dflags bndr)
-- Is the constructor tag in the node reg?
; if isSmallFamily fam_sz
; if isSmallFamily dflags fam_sz
then do
let -- Yes, bndr_reg has constr. tag in ls bits
tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
......
......@@ -347,8 +347,8 @@ ldvRecordCreate closure = do dflags <- getDynFlags
--
ldvEnterClosure :: ClosureInfo -> FCode ()
ldvEnterClosure closure_info = do dflags <- getDynFlags
let tag = funTag dflags closure_info
ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
where tag = funTag closure_info
-- don't forget to substract node's tag
ldvEnter :: CmmExpr -> FCode ()
......
......@@ -120,6 +120,8 @@ module DynFlags (
#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs"
bLOCK_SIZE_W,
wORD_SIZE_IN_BITS,
tAG_MASK,
mAX_PTR_TAG,
) where
#include "HsVersions.h"
......@@ -151,6 +153,7 @@ import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
import Control.Monad
import Data.Bits
import Data.Char
import Data.List
import Data.Map (Map)
......@@ -3153,3 +3156,9 @@ bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags
wORD_SIZE_IN_BITS :: DynFlags -> Int
wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8
tAG_MASK :: DynFlags -> Int
tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
mAX_PTR_TAG :: DynFlags -> Int
mAX_PTR_TAG = tAG_MASK
import Data.Bits (shiftL)
import Data.Word
import Data.Int
......@@ -57,14 +56,3 @@ tARGET_MAX_WORD = fromIntegral (maxBound :: TargetWord)
tARGET_MAX_CHAR :: Int
tARGET_MAX_CHAR = 0x10ffff
-- Amount of pointer bits used for semi-tagging constructor closures
tAG_BITS :: Int
tAG_BITS = TAG_BITS
tAG_MASK :: Int
tAG_MASK = (1 `shiftL` tAG_BITS) - 1
mAX_PTR_TAG :: Int
mAX_PTR_TAG = tAG_MASK
......@@ -697,6 +697,9 @@ main(int argc, char *argv[])
// Number of bits to shift a bitfield left by in an info table.
constantInt("bITMAP_BITS_SHIFT", BITMAP_BITS_SHIFT);