Move tAG_BITS into platformConstants
authorIan Lynagh <ian@well-typed.com>
Sun, 16 Sep 2012 19:55:26 +0000 (20:55 +0100)
committerIan Lynagh <ian@well-typed.com>
Sun, 16 Sep 2012 19:55:26 +0000 (20:55 +0100)
19 files changed:
compiler/cmm/CmmUtils.hs
compiler/codeGen/CgBindery.lhs
compiler/codeGen/CgClosure.lhs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgLetNoEscape.lhs
compiler/codeGen/CgProf.hs
compiler/codeGen/CgUtils.hs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmProf.hs
compiler/main/DynFlags.hs
includes/HaskellConstants.hs
includes/mkDerivedConstants.c

index 9a64531..bff4804 100644 (file)
@@ -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
index 4cb12a8..834276b 100644 (file)
@@ -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
index 0ed8738..11a5091 100644 (file)
@@ -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 }
index c2d9954..aeb8723 100644 (file)
@@ -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
index 03c0edd..e2a3aa2 100644 (file)
@@ -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]
index 2fb603b..610869a 100644 (file)
@@ -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}
index 4a611d1..6d87ee7 100644 (file)
@@ -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
index ab64f56..c52c8a8 100644 (file)
@@ -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)
 
 --------------------------------------------------------------------------
 --
index 20ac63f..7a72a00 100644 (file)
@@ -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}) = 
index 65e0103..f1022e5 100644 (file)
@@ -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
 
index 8f93303..02d3d02 100644 (file)
@@ -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
index b944208..85346da 100644 (file)
@@ -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 })
index 124e0cd..c822a64 100644 (file)
@@ -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 []
index 664a606..5106b97 100644 (file)
@@ -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
index ccd7d96..307d371 100644 (file)
@@ -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)
index 9eee38f..e6e9899 100644 (file)
@@ -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 ()
index cf1ce81..d4c3d53 100644 (file)
@@ -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
+
index e692a72..4ad7dee 100644 (file)
@@ -1,5 +1,4 @@
 
-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
-
index 86bf63e..558d709 100644 (file)
@@ -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);
 
+    // Amount of pointer bits used for semi-tagging constructor closures
+    constantInt("tAG_BITS", TAG_BITS);
+
     switch (mode) {
     case Gen_Haskell_Type:
         printf("  } deriving (Read, Show)\n");