Hold on to the full UpdateFlag information for longer
authorJoachim Breitner <mail@joachim-breitner.de>
Tue, 7 Aug 2012 14:38:51 +0000 (16:38 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Tue, 28 Aug 2012 14:18:37 +0000 (16:18 +0200)
compiler/cmm/CLabel.hs
compiler/codeGen/CgExpr.lhs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/stgSyn/StgSyn.lhs

index 6ffbbc7..44b183d 100644 (file)
@@ -119,6 +119,7 @@ import FastString
 import DynFlags
 import Platform
 import UniqSet
+import StgSyn (UpdateFlag(..))
 
 -- -----------------------------------------------------------------------------
 -- The CLabel type
@@ -301,11 +302,11 @@ data CaseLabelInfo
 
 
 data RtsLabelInfo
-  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks
-  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}
+  = RtsSelectorInfoTable UpdateFlag Int{-offset-}  -- ^ Selector thunks
+  | RtsSelectorEntry     UpdateFlag Int{-offset-}
 
-  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks
-  | RtsApEntry           Bool{-updatable-} Int{-arity-}
+  | RtsApInfoTable       UpdateFlag Int{-arity-}    -- ^ AP thunks
+  | RtsApEntry           UpdateFlag Int{-arity-}
 
   | RtsPrimOp PrimOp
   | RtsApFast     FastString    -- ^ _fast versions of generic apply
@@ -426,13 +427,13 @@ mkCmmGcPtrLabel     pkg str     = CmmLabel pkg str CmmGcPtr
 mkRtsPrimOpLabel :: PrimOp -> CLabel
 mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
 
-mkSelectorInfoLabel  :: Bool -> Int -> CLabel
-mkSelectorEntryLabel :: Bool -> Int -> CLabel
+mkSelectorInfoLabel  :: UpdateFlag -> Int -> CLabel
+mkSelectorEntryLabel :: UpdateFlag -> Int -> CLabel
 mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)
 mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)
 
-mkApInfoTableLabel :: Bool -> Int -> CLabel
-mkApEntryLabel     :: Bool -> Int -> CLabel
+mkApInfoTableLabel :: UpdateFlag -> Int -> CLabel
+mkApEntryLabel     :: UpdateFlag -> Int -> CLabel
 mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)
 mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)
 
@@ -995,30 +996,35 @@ pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> ptext (sLit "_fast")
 
 pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
   = hcat [ptext (sLit "stg_sel_"), text (show offset),
-                ptext (if upd_reqd
-                        then (sLit "_upd_info")
-                        else (sLit "_noupd_info"))
+                ptext (case upd_reqd of
+                    Updatable   -> sLit "_upd_info"
+                    SingleEntry -> sLit "_noupd_info"
+                    ReEntrant   -> error "stg_sel_*_noupd_info Not yet supported")
+
         ]
 
 pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
   = hcat [ptext (sLit "stg_sel_"), text (show offset),
-                ptext (if upd_reqd
-                        then (sLit "_upd_entry")
-                        else (sLit "_noupd_entry"))
+                ptext (case upd_reqd of
+                    Updatable   -> sLit "_upd_info"
+                    SingleEntry -> sLit "_noupd_info"
+                    ReEntrant   -> error "stg_sel_*_noupd_info Not yet supported")
         ]
 
 pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
   = hcat [ptext (sLit "stg_ap_"), text (show arity),
-                ptext (if upd_reqd
-                        then (sLit "_upd_info")
-                        else (sLit "_noupd_info"))
+                ptext (case upd_reqd of
+                    Updatable   -> sLit "_upd_info"
+                    SingleEntry -> sLit "_noupd_info"
+                    ReEntrant   -> error "stg_ap_*_noupd_info Not yet supported")
         ]
 
 pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
   = hcat [ptext (sLit "stg_ap_"), text (show arity),
-                ptext (if upd_reqd
-                        then (sLit "_upd_entry")
-                        else (sLit "_noupd_entry"))
+                ptext (case upd_reqd of
+                    Updatable   -> sLit "_upd_info"
+                    SingleEntry -> sLit "_noupd_info"
+                    ReEntrant   -> error "stg_ap_*_noupd_info Not yet supported")
         ]
 
 pprCLbl (CmmLabel _ fs CmmInfo)
index 0f10229..a5c1c09 100644 (file)
@@ -372,7 +372,7 @@ mkRhsClosure        dflags bndr cc bi
                []                      -- A thunk
                body@(StgCase _ _ _ _ srt _ _)  -- ignore uniq, etc.
   | Just offset_into_int <- isSelectorThunk dflags [the_fv] [] body
-  = let lf_info  = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+  = let lf_info  = mkSelectorLFInfo bndr offset_into_int upd_flag
     in  setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 \end{code}
 
index d3db24c..f8de0cb 100644 (file)
@@ -168,7 +168,7 @@ data LambdaFormInfo
   | LFThunk            -- Thunk (zero arity)
        TopLevelFlag
        !Bool           -- True <=> no free vars
-       !Bool           -- True <=> updatable (i.e., *not* single-entry)
+       !UpdateFlag     -- reentrant, updateable or single-entry
        StandardFormInfo
        !Bool           -- True <=> *might* be a function type
 
@@ -378,7 +378,7 @@ mkLFThunk :: Type -> TopLevelFlag -> [Var] -> UpdateFlag -> LambdaFormInfo
 mkLFThunk thunk_ty top fvs upd_flag
   = ASSERT2( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty), ppr thunk_ty $$ ppr fvs )
     LFThunk top (null fvs) 
-           (isUpdatable upd_flag)
+           upd_flag
            NonStandardThunk 
            (might_be_a_function thunk_ty)
 
@@ -404,14 +404,14 @@ maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
 maybeIsLFCon (LFCon con) = Just con
 maybeIsLFCon _ = Nothing
 
-mkSelectorLFInfo :: Id -> WordOff -> Bool -> LambdaFormInfo
+mkSelectorLFInfo :: Id -> WordOff -> UpdateFlag -> LambdaFormInfo
 mkSelectorLFInfo id offset updatable
   = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
        (might_be_a_function (idType id))
 
 mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+  = LFThunk NotTopLevel (arity == 0) upd_flag (ApThunk arity)
        (might_be_a_function (idType id))
 \end{code}
 
@@ -579,7 +579,7 @@ nodeMustPointToIt _ (LFCon _) = True
        -- 27/11/92.
 
 nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _)
-  = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
+  = isUpdatable updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
          -- For the non-updatable (single-entry case):
          --
          -- True if has fvs (in which case we need access to them, and we
@@ -897,7 +897,7 @@ closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
 closureUpdReqd ConInfo{} = False
 
 lfUpdatable :: LambdaFormInfo -> Bool
-lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable (LFThunk _ _ upd _ _)  = isUpdatable upd
 lfUpdatable LFBlackHole           = True
        -- Black-hole closures are allocated to receive the results of an
        -- alg case with a named default... so they need to be updated.
@@ -908,11 +908,12 @@ closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
 closureIsThunk ConInfo{} = False
 
 closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = isSingleEntry upd
 closureSingleEntry _ = False
 
 closureReEntrant :: ClosureInfo -> Bool
 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+-- TODO: What about LFThunk _ _ ReEntrant
 closureReEntrant _ = False
 
 isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
index 0f0bfb8..9c089f8 100644 (file)
@@ -254,7 +254,7 @@ mkRhsClosure    dflags bndr _cc _bi
     cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
   where
     lf_info               = mkSelectorLFInfo bndr offset_into_int
-                                 (isUpdatable upd_flag)
+                                 upd_flag
     (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
                                -- Just want the layout
     maybe_offset          = assocMaybe params_w_offsets (NonVoid selectee)
index 2afcb6a..6c64d69 100644 (file)
@@ -137,7 +137,7 @@ data LambdaFormInfo
   | LFThunk            -- Thunk (zero arity)
        TopLevelFlag
        !Bool           -- True <=> no free vars
-       !Bool           -- True <=> updatable (i.e., *not* single-entry)
+       !UpdateFlag     -- reentrant, updateable or single-entry
        StandardFormInfo
        !Bool           -- True <=> *might* be a function type
 
@@ -225,7 +225,7 @@ mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
 mkLFThunk thunk_ty top fvs upd_flag
   = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
     LFThunk top (null fvs) 
-           (isUpdatable upd_flag)
+           upd_flag
            NonStandardThunk 
            (might_be_a_function thunk_ty)
 
@@ -246,7 +246,7 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
 mkConLFInfo con = LFCon con
 
 -------------
-mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
+mkSelectorLFInfo :: Id -> Int -> UpdateFlag -> LambdaFormInfo
 mkSelectorLFInfo id offset updatable
   = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
        (might_be_a_function (idType id))
@@ -254,7 +254,7 @@ mkSelectorLFInfo id offset updatable
 -------------
 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+  = LFThunk NotTopLevel (arity == 0) upd_flag (ApThunk arity)
        (might_be_a_function (idType id))
 
 -------------
@@ -402,7 +402,7 @@ nodeMustPointToIt _ (LFCon _) = True
        -- 27/11/92.
 
 nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _)
-  = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
+  = isUpdatable updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
          -- For the non-updatable (single-entry case):
          --
          -- True if has fvs (in which case we need access to them, and we
@@ -498,7 +498,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg
                -- is the fast-entry code]
 
   -- Since is_fun is False, we are *definitely* looking at a data value
-  | updatable || doingTickyProfiling dflags -- to catch double entry
+  | isUpdatable updatable || doingTickyProfiling dflags -- to catch double entry
       {- OLD: || opt_SMP
         I decided to remove this, because in SMP mode it doesn't matter
         if we enter the same thunk multiple times, so the optimisation
@@ -734,18 +734,19 @@ closureUpdReqd :: ClosureInfo -> Bool
 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
 
 lfUpdatable :: LambdaFormInfo -> Bool
-lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable (LFThunk _ _ upd _ _)  = isUpdatable upd
 lfUpdatable LFBlackHole           = True
        -- Black-hole closures are allocated to receive the results of an
        -- alg case with a named default... so they need to be updated.
 lfUpdatable _ = False
 
 closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = isSingleEntry upd
 closureSingleEntry _ = False
 
 closureReEntrant :: ClosureInfo -> Bool
 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+-- TODO: What about LFThunk _ _ ReEntrant
 closureReEntrant _ = False
 
 closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
@@ -812,7 +813,7 @@ mkClosureInfoTableLabel id lf_info
        -- invariants in CorePrep anything else gets eta expanded.
 
 
-thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
+thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> UpdateFlag -> CLabel
 -- thunkEntryLabel is a local help function, not exported.  It's used from
 -- getCallMethod.
 thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
@@ -822,12 +823,12 @@ thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
 thunkEntryLabel dflags thunk_id c _ _
   = enterIdLabel dflags thunk_id c
 
-enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
+enterApLabel :: DynFlags -> UpdateFlag -> Arity -> CLabel
 enterApLabel dflags is_updatable arity
   | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
   | otherwise               = mkApEntryLabel is_updatable arity
 
-enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
+enterSelectorLabel :: DynFlags -> UpdateFlag -> WordOff -> CLabel
 enterSelectorLabel dflags upd_flag offset
   | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
   | otherwise               = mkSelectorEntryLabel upd_flag offset
index 84a4c69..ee2167a 100644 (file)
@@ -17,7 +17,7 @@ module StgSyn (
         GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
-        UpdateFlag(..), isUpdatable,
+        UpdateFlag(..), isUpdatable, isSingleEntry,
 
         StgBinderInfo,
         noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
@@ -552,6 +552,7 @@ safely be blackholed.
 
 \begin{code}
 data UpdateFlag = ReEntrant | Updatable | SingleEntry
+  deriving (Eq, Ord)
 
 instance Outputable UpdateFlag where
     ppr u = char $ case u of
@@ -563,6 +564,11 @@ isUpdatable :: UpdateFlag -> Bool
 isUpdatable ReEntrant   = False
 isUpdatable SingleEntry = False
 isUpdatable Updatable   = True
+
+isSingleEntry :: UpdateFlag -> Bool
+isSingleEntry ReEntrant   = False
+isSingleEntry SingleEntry = True
+isSingleEntry Updatable   = False
 \end{code}
 
 %************************************************************************