summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/CmmUtils.hs5
-rw-r--r--compiler/codeGen/CgBindery.lhs71
-rw-r--r--compiler/codeGen/CgClosure.lhs10
-rw-r--r--compiler/codeGen/CgCon.lhs19
-rw-r--r--compiler/codeGen/CgInfoTbls.hs2
-rw-r--r--compiler/codeGen/CgLetNoEscape.lhs5
-rw-r--r--compiler/codeGen/CgProf.hs2
-rw-r--r--compiler/codeGen/CgUtils.hs15
-rw-r--r--compiler/codeGen/ClosureInfo.lhs20
-rw-r--r--compiler/codeGen/StgCmm.hs7
-rw-r--r--compiler/codeGen/StgCmmBind.hs4
-rw-r--r--compiler/codeGen/StgCmmClosure.hs33
-rw-r--r--compiler/codeGen/StgCmmCon.hs18
-rw-r--r--compiler/codeGen/StgCmmEnv.hs16
-rw-r--r--compiler/codeGen/StgCmmExpr.hs2
-rw-r--r--compiler/codeGen/StgCmmProf.hs2
-rw-r--r--compiler/main/DynFlags.hs9
17 files changed, 127 insertions, 113 deletions
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 9a645312a6..bff4804fc2 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -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
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs
index 4cb12a8194..834276bd7b 100644
--- a/compiler/codeGen/CgBindery.lhs
+++ b/compiler/codeGen/CgBindery.lhs
@@ -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
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 0ed87384d3..11a5091c07 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -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 }
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index c2d99541c6..aeb87235e3 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -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
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 03c0edde36..e2a3aa2efd 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -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]
diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs
index 2fb603baed..610869ad89 100644
--- a/compiler/codeGen/CgLetNoEscape.lhs
+++ b/compiler/codeGen/CgLetNoEscape.lhs
@@ -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}
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 4a611d1e1d..6d87ee7127 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -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
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index ab64f56c4b..c52c8a8c99 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -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)
--------------------------------------------------------------------------
--
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 20ac63f6d2..7a72a00602 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -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}) =
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 65e0103099..f1022e5280 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 8f93303630..02d3d0246f 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index b944208a07..85346da205 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -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 })
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 124e0cd9d3..c822a64e2c 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -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 []
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 664a606091..5106b971b1 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index ccd7d96231..307d3715b3 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -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)
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index 9eee38f7cb..e6e9899040 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -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 ()
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index cf1ce81a15..d4c3d535d6 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
+
View Lorry Controller Status