Cleanup StgCmm pass
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Tue, 20 Aug 2013 10:53:05 +0000 (11:53 +0100)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Tue, 20 Aug 2013 16:19:30 +0000 (17:19 +0100)
This cleanup includes:
  * removing dead code. This includes forkStatics function,
    which was in fact one big noop, and global bindings in
    CgInfoDownwards,
  * converting functions that used FCode monad only to
    access DynFlags into functions that take DynFlags
    as a parameter and don't work in a monad,
  * addBindC function is now smarter. It extracts Id from
    CgIdInfo passed to it in the same way addBindsC does.
    Previously this was done at every call site, which was
    redundant.

compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs

index 57b0cda..8b3bac3 100644 (file)
@@ -118,33 +118,33 @@ variable. -}
 cgTopBinding :: DynFlags -> StgBinding -> FCode ()
 cgTopBinding dflags (StgNonRec id rhs)
   = do  { id' <- maybeExternaliseId dflags id
-        ; (info, fcode) <- cgTopRhs NonRecursive id' rhs
+        ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
         ; fcode
-        ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
-                                     -- so we find it when we look up occurrences
+        ; addBindC info -- Add the *un-externalised* Id to the envt,
+                        -- so we find it when we look up occurrences
         }
 
 cgTopBinding dflags (StgRec pairs)
   = do  { let (bndrs, rhss) = unzip pairs
         ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
         ; let pairs' = zip bndrs' rhss
-        ; r <- sequence $ unzipWith (cgTopRhs Recursive) pairs'
-        ; let (infos, fcodes) = unzip r
+              r = unzipWith (cgTopRhs dflags Recursive) pairs'
+              (infos, fcodes) = unzip r
         ; addBindsC infos
         ; sequence_ fcodes
         }
 
 
-cgTopRhs :: RecFlag -> Id -> StgRhs -> FCode (CgIdInfo, FCode ())
+cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
         -- The Id is passed along for setting up a binding...
         -- It's already been externalised if necessary
 
-cgTopRhs _rec bndr (StgRhsCon _cc con args)
-  = forkStatics (cgTopRhsCon bndr con args)
+cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
+  = cgTopRhsCon dflags bndr con args
 
-cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
+cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
   = ASSERT(null fvs)    -- There should be no free variables
-    forkStatics (cgTopRhsClosure rec bndr cc bi upd_flag args body)
+    cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
 
 
 ---------------------------------------------------------------
index 7cac6ad..ba1e059 100644 (file)
@@ -58,22 +58,21 @@ import Control.Monad
 -- For closures bound at top level, allocate in static space.
 -- They should have no free variables.
 
-cgTopRhsClosure :: RecFlag              -- member of a recursive group?
+cgTopRhsClosure :: DynFlags
+                -> RecFlag              -- member of a recursive group?
                 -> Id
                 -> CostCentreStack      -- Optional cost centre annotation
                 -> StgBinderInfo
                 -> UpdateFlag
                 -> [Id]                 -- Args
                 -> StgExpr
-                -> FCode (CgIdInfo, FCode ())
-
-cgTopRhsClosure rec id ccs _ upd_flag args body
- = do { dflags <- getDynFlags
-      ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
-      ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
-            cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)
-      ; return (cg_id_info, gen_code dflags lf_info closure_label)
-      }
+                -> (CgIdInfo, FCode ())
+
+cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)
+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args
+  in (cg_id_info, gen_code dflags lf_info closure_label)
   where
   -- special case for a indirection (f = g).  We create an IND_STATIC
   -- closure pointing directly to the indirectee.  This is exactly
@@ -128,7 +127,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body
 cgBind :: StgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
   = do  { (info, fcode) <- cgRhs name rhs
-        ; addBindC (cg_id info) info
+        ; addBindC info
         ; init <- fcode
         ; emit init }
         -- init cannot be used in body, so slightly better to sink it eagerly
@@ -316,8 +315,8 @@ mkRhsClosure    dflags bndr _cc _bi
         arity   = length fvs
 
 ---------- Default case ------------------
-mkRhsClosure _ bndr cc _ fvs upd_flag args body
-  = do  { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+mkRhsClosure dflags bndr cc _ fvs upd_flag args body
+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args
         ; (id_info, reg) <- rhsIdInfo bndr lf_info
         ; return (id_info, gen_code lf_info reg) }
  where
@@ -410,17 +409,18 @@ cgRhsStdThunk bndr lf_info payload
   ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
 
 
-mkClosureLFInfo :: Id           -- The binder
+mkClosureLFInfo :: DynFlags
+                -> Id           -- The binder
                 -> TopLevelFlag -- True of top level
                 -> [NonVoid Id] -- Free vars
                 -> UpdateFlag   -- Update flag
                 -> [Id]         -- Args
-                -> FCode LambdaFormInfo
-mkClosureLFInfo bndr top fvs upd_flag args
-  | null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag)
+                -> LambdaFormInfo
+mkClosureLFInfo dflags bndr top fvs upd_flag args
+  | null args =
+        mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag
   | otherwise =
-      do { arg_descr <- mkArgDescr (idName bndr) args
-         ; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) }
+        mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args)
 
 
 ------------------------------------------------------------------------
index 4f12948..57d4759 100644 (file)
@@ -50,22 +50,21 @@ import Data.Char
 --      Top-level constructors
 ---------------------------------------------------------------
 
-cgTopRhsCon :: Id               -- Name of thing bound to this RHS
+cgTopRhsCon :: DynFlags
+            -> Id               -- Name of thing bound to this RHS
             -> DataCon          -- Id
             -> [StgArg]         -- Args
-            -> FCode (CgIdInfo, FCode ())
-cgTopRhsCon id con args
-  = do dflags <- getDynFlags
-       let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
-       return ( id_info, gen_code )
+            -> (CgIdInfo, FCode ())
+cgTopRhsCon dflags id con args =
+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
+    in (id_info, gen_code)
   where
    name          = idName id
    caffy         = idCafInfo id -- any stgArgHasCafRefs args
    closure_label = mkClosureLabel name caffy
 
    gen_code =
-     do { dflags <- getDynFlags
-        ; this_mod <- getModuleName
+     do { this_mod <- getModuleName
         ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
               -- Windows DLLs have a problem with static cross-DLL refs.
               ASSERT( not (isDllConApp dflags this_mod con args) ) return ()
index 77a3b4e..353fec5 100644 (file)
@@ -8,8 +8,6 @@
 module StgCmmEnv (
         CgIdInfo,
 
-        cgIdInfoId, cgIdInfoLF,
-
         litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
         idInfoToAmode,
 
@@ -113,12 +111,6 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
 -- A tag adds a byte offset to the pointer
 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
 
-cgIdInfoId :: CgIdInfo -> Id
-cgIdInfoId = cg_id
-
-cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
-cgIdInfoLF = cg_lf
-
 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
 maybeLetNoEscape _other                                      = Nothing
@@ -132,10 +124,10 @@ maybeLetNoEscape _other                                      = Nothing
 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
 ---------------------------------------------------------
 
-addBindC :: Id -> CgIdInfo -> FCode ()
-addBindC name stuff_to_bind = do
+addBindC :: CgIdInfo -> FCode ()
+addBindC stuff_to_bind = do
         binds <- getBinds
-        setBinds $ extendVarEnv binds name stuff_to_bind
+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
 
 addBindsC :: [CgIdInfo] -> FCode ()
 addBindsC new_bindings = do
@@ -147,39 +139,26 @@ addBindsC new_bindings = do
 
 getCgIdInfo :: Id -> FCode CgIdInfo
 getCgIdInfo id
-  = do        {         -- Try local bindings first
-        ; local_binds  <- getBinds
+  = do  { dflags <- getDynFlags
+        ; local_binds <- getBinds -- Try local bindings first
         ; case lookupVarEnv local_binds id of {
             Just info -> return info ;
-            Nothing   -> do
-
-        {         -- Try top-level bindings
-          static_binds <- getStaticBinds
-        ; case lookupVarEnv static_binds id of {
-            Just info -> return info ;
-            Nothing   ->
+            Nothing   -> do {
 
                 -- Should be imported; make up a CgIdInfo for it
-        let
-            name = idName id
-        in
-        if isExternalName name then do
-            let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
-            dflags <- getDynFlags
-            return (litIdInfo dflags id (mkLFImported id) ext_lbl)
-        else
-            -- Bug
-            cgLookupPanic id
-        }}}}
+          let name = idName id
+        ; if isExternalName name then
+              let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
+              in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
+          else
+              cgLookupPanic id -- Bug
+        }}}
 
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
-  = do  static_binds <- getStaticBinds
-        local_binds <- getBinds
+  = do  local_binds <- getBinds
         pprPanic "StgCmmEnv: variable not found"
                 (vcat [ppr id,
-                ptext (sLit "static binds for:"),
-                vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
                 ptext (sLit "local binds for:"),
                 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
               ])
@@ -210,7 +189,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 (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        return reg
 
 rebindToReg :: NonVoid Id -> FCode LocalReg
@@ -218,7 +197,7 @@ rebindToReg :: NonVoid Id -> FCode LocalReg
 -- get its LF info from the envt
 rebindToReg nvid@(NonVoid id)
   = do  { info <- getCgIdInfo id
-        ; bindToReg nvid (cgIdInfoLF info) }
+        ; bindToReg nvid (cg_lf info) }
 
 bindArgToReg :: NonVoid Id -> FCode LocalReg
 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
index 00c6068..b19341b 100644 (file)
@@ -106,7 +106,7 @@ cgLneBinds join_id (StgNonRec bndr rhs)
                 -- See Note [Saving the current cost centre]
         ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
         ; fcode
-        ; addBindC (cg_id info) info }
+        ; addBindC info }
 
 cgLneBinds join_id (StgRec pairs)
   = do  { local_cc <- saveCurrentCostCentre
@@ -676,9 +676,9 @@ cgTailCall fun_id fun_info args = do
 
   where
     fun_arg     = StgVarArg fun_id
-    fun_name    = idName            fun_id
-    fun         = idInfoToAmode     fun_info
-    lf_info     = cgIdInfoLF        fun_info
+    fun_name    = idName        fun_id
+    fun         = idInfoToAmode fun_info
+    lf_info     = cg_lf         fun_info
     node_points dflags = nodeMustPointToIt dflags lf_info
 
 
index c6e57d5..6c6e49d 100644 (file)
@@ -39,8 +39,7 @@ import CmmInfo
 import CLabel
 import StgSyn
 import Id
-import Name
-import TyCon                ( PrimRep(..) )
+import TyCon             ( PrimRep(..) )
 import BasicTypes        ( RepArity )
 import DynFlags
 import Module
@@ -360,15 +359,14 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
 -- bring in ARG_P, ARG_N, etc.
 #include "../includes/rts/storage/FunTypes.h"
 
-mkArgDescr :: Name -> [Id] -> FCode ArgDescr
-mkArgDescr _nm args
-  = do dflags <- getDynFlags
-       let arg_bits = argBits dflags arg_reps
-           arg_reps = filter isNonV (map idArgRep args)
+mkArgDescr :: DynFlags -> [Id] -> ArgDescr
+mkArgDescr dflags args
+  = let arg_bits = argBits dflags arg_reps
+        arg_reps = filter isNonV (map idArgRep args)
            -- Getting rid of voids eases matching of standard patterns
-       case stdPattern arg_reps of
-           Just spec_id -> return (ArgSpec spec_id)
-           Nothing      -> return (ArgGen arg_bits)
+    in case stdPattern arg_reps of
+         Just spec_id -> ArgSpec spec_id
+         Nothing      -> ArgGen  arg_bits
 
 argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
 argBits _      []           = []
index 37b0a26..978cfa2 100644 (file)
@@ -26,7 +26,7 @@ module StgCmmMonad (
         mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
         mkCall, mkCmmCall,
 
-        forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
+        forkClosureBody, forkAlts, forkProc, codeOnly,
 
         ConTagZ,
 
@@ -48,7 +48,7 @@ module StgCmmMonad (
 
         -- more localised access to monad state
         CgIdInfo(..), CgLoc(..),
-        getBinds, setBinds, getStaticBinds,
+        getBinds, setBinds,
 
         -- out of general friendliness, we also export ...
         CgInfoDownwards(..), CgState(..)        -- non-abstract
@@ -171,7 +171,6 @@ data CgInfoDownwards        -- information only passed *downwards* by the monad
   = MkCgInfoDown {
         cgd_dflags     :: DynFlags,
         cgd_mod        :: Module,          -- Module being compiled
-        cgd_statics    :: CgBindings,          -- [Id -> info] : static environment
         cgd_updfr_off  :: UpdFrameOffset, -- Size of current update frame
         cgd_ticky      :: CLabel,          -- Current destination for ticky counts
         cgd_sequel     :: Sequel          -- What to do at end of basic block
@@ -299,7 +298,6 @@ initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 initCgInfoDown dflags mod
   = MkCgInfoDown { cgd_dflags    = dflags
                  , cgd_mod       = mod
-                 , cgd_statics   = emptyVarEnv
                  , cgd_updfr_off = initUpdFrameOff dflags
                  , cgd_ticky     = mkTopTickyCtrLabel
                  , cgd_sequel    = initSequel }
@@ -428,11 +426,6 @@ setBinds new_binds = do
         state <- getState
         setState $ state {cgs_binds = new_binds}
 
-getStaticBinds :: FCode CgBindings
-getStaticBinds = do
-        info  <- getInfoDown
-        return (cgd_statics info)
-
 withState :: FCode a -> CgState -> FCode (a,CgState)
 withState (FCode fcode) newstate = FCode $ \info_down state ->
   case fcode info_down newstate of
@@ -548,24 +541,6 @@ forkClosureBody body_code
               ((),fork_state_out) = doFCode body_code body_info_down fork_state_in
         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 
-forkStatics :: FCode a -> FCode a
--- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
--- from the current *local bindings*, but which is otherwise freshly initialised.
--- The Abstract~C returned is attached to the current state, but the
--- bindings and usage information is otherwise unchanged.
-forkStatics body_code
-  = do  { dflags <- getDynFlags
-        ; info   <- getInfoDown
-        ; us     <- newUniqSupply
-        ; state  <- getState
-        ; let   rhs_info_down = info { cgd_statics = cgs_binds state
-                                     , cgd_sequel  = initSequel
-                                     , cgd_updfr_off = initUpdFrameOff dflags }
-                (result, fork_state_out) = doFCode body_code rhs_info_down
-                                                   (initCgState us)
-        ; setState (state `addCodeBlocksFrom` fork_state_out)
-        ; return result }
-
 forkProc :: FCode a -> FCode a
 -- 'forkProc' takes a code and compiles it in the *current* environment,
 -- returning the graph thus constructed.