Cleanup StgCmm pass

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.

7 files changed, 66 insertions, 115 deletions

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 57b0cdaf89..8b3bac3b4f 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -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
 
 
 ---------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 7cac6ad263..ba1e0597ba 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -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)
 
 
 ------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 4f12948bcc..57d4759346 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -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 ()
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 77a3b4e249..353fec5a5f 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -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)
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 00c6068fb0..b19341bc8c 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -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
 
 
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index c6e57d5041..6c6e49dafa 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -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 _      []           = []
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 37b0a26df6..978cfa2ad2 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -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.