Remove unused LiveVars and SRT fields of StgCase
authorÖmer Sinan Ağacan <omeragacan@gmail.com>
Mon, 8 Feb 2016 21:18:23 +0000 (16:18 -0500)
committerÖmer Sinan Ağacan <omeragacan@gmail.com>
Mon, 8 Feb 2016 21:19:28 +0000 (16:19 -0500)
We also need to update `stgBindHasCafRefs` assertion with this change,
as we no longer have the pre-computed SRT, LiveVars etc. We rename it to
`topStgBindHasCafRefs` and implement it like this:

A non-updatable top-level binding may refer to a CAF by referring to a
top-level definition with CAFs. A top-level definition may have CAFs if
it's updatable. At this point (because this is done after TidyPgm)
top-level Ids (whether imported or defined in this module) are
GlobalIds, so the top-levelness test is easy. (see also comments in the
code)

Reviewers: bgamari, simonpj, austin

Reviewed By: simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1889

GHC Trac Issues: #11550

compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmExpr.hs
compiler/main/HscMain.hs
compiler/profiling/SCCfinal.hs
compiler/simplStg/StgStats.hs
compiler/simplStg/UnariseStg.hs
compiler/stgSyn/CoreToStg.hs
compiler/stgSyn/StgLint.hs
compiler/stgSyn/StgSyn.hs

index b0dd9b1..9d14db9 100644 (file)
@@ -141,7 +141,7 @@ cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
 cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
   = cgTopRhsCon dflags bndr con args
 
-cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
+cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)
   = ASSERT(null fvs)    -- There should be no free variables
     cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
 
index fde662b..ea05e8d 100644 (file)
@@ -210,7 +210,7 @@ cgRhs id (StgRhsCon cc con args)
     buildDynCon id True cc con args
 
 {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
-cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
+cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
   = do dflags <- getDynFlags
        mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
 
@@ -268,7 +268,7 @@ mkRhsClosure    dflags bndr _cc _bi
                 expr
   | let strip = snd . stripStgTicksTop (not . tickishIsCode)
   , StgCase (StgApp scrutinee [{-no args-}])
-         _ _ _ _   -- ignore uniq, etc.
+         _   -- ignore bndr
          (AlgAlt _)
          [(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
   , StgApp selectee [{-no args-}] <- strip sel_expr
index 923450e..0f3898b 100644 (file)
@@ -71,7 +71,7 @@ cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
                                emitReturn [CmmLit cmm_lit]
 
 cgExpr (StgLet binds expr)             = do { cgBind binds;     cgExpr expr }
-cgExpr (StgLetNoEscape _ _ binds expr) =
+cgExpr (StgLetNoEscape binds expr) =
   do { u <- newUnique
      ; let join_id = mkBlockId u
      ; cgLneBinds join_id binds
@@ -79,7 +79,7 @@ cgExpr (StgLetNoEscape _ _ binds expr) =
      ; emitLabel join_id
      ; return r }
 
-cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) =
+cgExpr (StgCase expr bndr alt_type alts) =
   cgCase expr bndr alt_type alts
 
 cgExpr (StgLam {}) = panic "cgExpr: StgLam"
@@ -140,7 +140,7 @@ cgLetNoEscapeRhsBody
     -> Id
     -> StgRhs
     -> FCode (CgIdInfo, FCode ())
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
   = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
index 58434e9..4b26cdb 100644 (file)
@@ -1436,8 +1436,8 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
             -> IO ( [StgBinding] -- output program
                   , CollectedCCs) -- cost centre info (declared and used)
 myCoreToStg dflags this_mod prepd_binds = do
-    stg_binds
-        <- {-# SCC "Core2Stg" #-}
+    let stg_binds
+         = {-# SCC "Core2Stg" #-}
            coreToStg dflags this_mod prepd_binds
 
     (stg_binds2, cost_centre_info)
index 6cab87c..6bd00b0 100644 (file)
@@ -90,7 +90,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
     ----------
     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 
-    do_top_rhs _ (StgRhsClosure _ _ _ _ []
+    do_top_rhs _ (StgRhsClosure _ _ _ _ []
                      (StgTick (ProfNote _cc False{-not tick-} _push)
                               (StgConApp con args)))
       | not (isDllConApp dflags mod_name con args)
@@ -100,7 +100,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
         -- isDllConApp checks for LitLit args too
       = return (StgRhsCon dontCareCCS con args)
 
-    do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body)
+    do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
       = do
         -- Top level CAF without a cost centre attached
         -- Attach CAF cc (collect if individual CAF ccs)
@@ -119,11 +119,11 @@ stgMassageForProfiling dflags mod_name _us stg_binds
                    else
                         return all_cafs_ccs
         body' <- do_expr body
-        return (StgRhsClosure caf_ccs bi fv u srt [] body')
+        return (StgRhsClosure caf_ccs bi fv u [] body')
 
-    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
+    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
       = do body' <- do_expr body
-           return (StgRhsClosure dontCareCCS bi fv u srt args body')
+           return (StgRhsClosure dontCareCCS bi fv u args body')
 
     do_top_rhs _ (StgRhsCon _ con args)
         -- Top-level (static) data is not counted in heap
@@ -155,10 +155,10 @@ stgMassageForProfiling dflags mod_name _us stg_binds
         expr' <- do_expr expr
         return (StgTick ti expr')
 
-    do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
+    do_expr (StgCase expr bndr alt_type alts) = do
         expr' <- do_expr expr
         alts' <- mapM do_alt alts
-        return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
+        return (StgCase expr' bndr alt_type alts')
       where
         do_alt (id, bs, use_mask, e) = do
             e' <- do_expr e
@@ -168,9 +168,9 @@ stgMassageForProfiling dflags mod_name _us stg_binds
           (b,e) <- do_let b e
           return (StgLet b e)
 
-    do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
+    do_expr (StgLetNoEscape b e) = do
           (b,e) <- do_let b e
-          return (StgLetNoEscape lvs1 lvs2 b e)
+          return (StgLetNoEscape b e)
 
     do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
 
@@ -200,15 +200,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds
         -- allocation of the constructor to the wrong place (XXX)
         -- We should really attach (PushCC cc CurrentCCS) to the rhs,
         -- but need to reinstate PushCC for that.
-    do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt []
+    do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
                (StgTick (ProfNote cc False{-not tick-} _push)
                         (StgConApp con args)))
       = do collectCC cc
            return (StgRhsCon currentCCS con args)
 
-    do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
+    do_rhs (StgRhsClosure _ bi fv u args expr) = do
         expr' <- do_expr expr
-        return (StgRhsClosure currentCCS bi fv u srt args expr')
+        return (StgRhsClosure currentCCS bi fv u args expr')
 
     do_rhs (StgRhsCon _ con args)
       = return (StgRhsCon currentCCS con args)
index dd1f5a6..5860f61 100644 (file)
@@ -127,7 +127,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
 statRhs top (_, StgRhsCon _ _ _)
   = countOne (ConstructorBinds top)
 
-statRhs top (_, StgRhsClosure _ _ fv u _ body)
+statRhs top (_, StgRhsClosure _ _ fv u _ body)
   = statExpr body                       `combineSE`
     countN FreeVariables (length fv)    `combineSE`
     countOne (
@@ -153,7 +153,7 @@ statExpr (StgConApp _ _)  = countOne ConstructorApps
 statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
 statExpr (StgTick _ e)    = statExpr e
 
-statExpr (StgLetNoEscape _ _ binds body)
+statExpr (StgLetNoEscape binds body)
   = statBinding False{-not top-level-} binds    `combineSE`
     statExpr body                               `combineSE`
     countOne LetNoEscapes
@@ -162,7 +162,7 @@ statExpr (StgLet binds body)
   = statBinding False{-not top-level-} binds    `combineSE`
     statExpr body
 
-statExpr (StgCase expr _ _ _ _ _ alts)
+statExpr (StgCase expr _ _ alts)
   = statExpr expr       `combineSE`
     stat_alts alts      `combineSE`
     countOne StgCases
index b162201..705fce0 100644 (file)
@@ -42,7 +42,6 @@ import MkId (realWorldPrimId)
 import Type
 import TysWiredIn
 import DataCon
-import VarSet
 import OccName
 import Name
 import Util
@@ -74,9 +73,9 @@ unariseBinding us rho bind = case bind of
 
 unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
 unariseRhs us rho rhs = case rhs of
-  StgRhsClosure ccs b_info fvs update_flag srt args expr
+  StgRhsClosure ccs b_info fvs update_flag args expr
     -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag
-                     (unariseSRT rho srt) args' (unariseExpr us' rho' expr)
+                     args' (unariseExpr us' rho' expr)
     where (us', rho', args') = unariseIdBinders us rho args
   StgRhsCon ccs con args
     -> StgRhsCon ccs con (unariseArgs rho args)
@@ -111,10 +110,8 @@ unariseExpr us rho (StgLam xs e)
   where
     (us', rho', xs') = unariseIdBinders us rho xs
 
-unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts)
-  = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives)
-            (unariseLives rho alts_lives) bndr (unariseSRT rho srt)
-            alt_ty alts'
+unariseExpr us rho (StgCase e bndr alt_ty alts)
+  = StgCase (unariseExpr us1 rho e) bndr alt_ty alts'
  where
     (us1, us2) = splitUniqSupply us
     alts'      = unariseAlts us2 rho alt_ty bndr alts
@@ -124,9 +121,8 @@ unariseExpr us rho (StgLet bind e)
   where
     (us1, us2) = splitUniqSupply us
 
-unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
-  = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind)
-                   (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
+unariseExpr us rho (StgLetNoEscape bind e)
+  = StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
   where
     (us1, us2) = splitUniqSupply us
 
@@ -161,13 +157,6 @@ unariseAlt us rho (con, xs, uses, e)
     (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses
 
 ------------------------
-unariseSRT :: UnariseEnv -> SRT -> SRT
-unariseSRT _   NoSRT            = NoSRT
-unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids)
-
-unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars
-unariseLives rho ids = concatMapVarSet (unariseId rho) ids
-
 unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg]
 unariseArgs rho = concatMap (unariseArg rho)
 
@@ -212,6 +201,3 @@ unariseIdBinder us rho x = case repType (idType x) of
 unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id]
 unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys
   where fs = occNameFS (getOccName x)
-
-concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet
-concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x]
index 0f81ab3..414571c 100644 (file)
@@ -50,11 +50,10 @@ import Control.Monad (liftM, ap)
 -- Note [Live vs free]
 -- ~~~~~~~~~~~~~~~~~~~
 --
--- The actual Stg datatype is decorated with live variable information, as well
--- as free variable information. The two are not the same. Liveness is an
--- operational property rather than a semantic one. A variable is live at a
--- particular execution point if it can be referred to directly again. In
--- particular, a dead variable's stack slot (if it has one):
+-- The two are not the same. Liveness is an operational property rather
+-- than a semantic one. A variable is live at a particular execution
+-- point if it can be referred to directly again. In particular, a dead
+-- variable's stack slot (if it has one):
 --
 --           - should be stubbed to avoid space leaks, and
 --           - may be reused for something else.
@@ -88,8 +87,7 @@ import Control.Monad (liftM, ap)
 -- Note [Collecting live CAF info]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
--- In this pass we also collect information on which CAFs are live for
--- constructing SRTs (see SRT.hs).
+-- In this pass we also collect information on which CAFs are live.
 --
 -- A top-level Id has CafInfo, which is
 --
@@ -108,24 +106,6 @@ import Control.Monad (liftM, ap)
 -- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
 -- pairs.
 
-
--- Note [Interaction of let-no-escape with SRTs]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Consider
---
---         let-no-escape x = ...caf1...caf2...
---         in
---         ...x...x...x...
---
--- where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
--- build SRTs just as if x's defn was inlined at each call site, and
--- that means that x's CAF refs get duplicated in the overall SRT.
---
--- This is unlike ordinary lets, in which the CAF refs are not duplicated.
---
--- We could fix this loss of (static) sharing by making a sort of pseudo-closure
--- for x, solely to put in the SRTs lower down.
-
 -- Note [What is a non-escaping let]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
@@ -186,9 +166,9 @@ import Control.Monad (liftM, ap)
 -- Setting variable info: top-level, binds, RHSs
 -- --------------------------------------------------------------
 
-coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
+coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
 coreToStg dflags this_mod pgm
-  = return pgm'
+  = pgm'
   where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
 
 coreExprToStg :: CoreExpr -> StgExpr
@@ -273,7 +253,7 @@ consistentCafInfo id bind
     safe  = id_marked_caffy || not binding_is_caffy
     exact = id_marked_caffy == binding_is_caffy
     id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
-    binding_is_caffy = stgBindHasCafRefs bind
+    binding_is_caffy = topStgBindHasCafRefs bind
     is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
 
 coreToTopStgRhs
@@ -285,9 +265,8 @@ coreToTopStgRhs
 
 coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
   = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
-       ; lv_info <- freeVarsToLiveVars rhs_fvs
 
-       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs
+       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs
              stg_arity = stgRhsArity stg_rhs
        ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
                  rhs_fvs) }
@@ -314,7 +293,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
                 text "STG arity:" <+> ppr stg_arity]
 
 mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-            -> SRT -> Id -> StgBinderInfo -> StgExpr
+            -> Id -> StgBinderInfo -> StgExpr
             -> StgRhs
 
 mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
@@ -414,23 +393,12 @@ coreToStgExpr (Case scrut bndr _ alts) = do
         alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
         alts_escs_wo_bndr = alts_escs `delVarSet` bndr
 
-    alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
-
         -- We tell the scrutinee that everything
         -- live in the alts is live in it, too.
-    (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
-       <- setVarsLiveInCont alts_lv_info $ do
-            (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
-            scrut_lv_info <- freeVarsToLiveVars scrut_fvs
-            return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
+    (scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut
 
     return (
-      StgCase scrut2 (getLiveVars scrut_lv_info)
-                     (getLiveVars alts_lv_info)
-                     bndr'
-                     (mkSRT alts_lv_info)
-                     (mkStgAltType bndr alts)
-                     alts2,
+      StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
                 -- You might think we should have scrut_escs, not
@@ -682,39 +650,29 @@ coreToStgLet
                                 -- is among the escaping vars
 
 coreToStgLet let_no_escape bind body = do
-    (bind2, bind_fvs, bind_escs, bind_lvs,
-     body2, body_fvs, body_escs, body_lvs)
-       <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
-
-          -- Do the bindings, setting live_in_cont to empty if
-          -- we ain't in a let-no-escape world
-          live_in_cont <- getVarsLiveInCont
-          ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
-                <- setVarsLiveInCont (if let_no_escape
-                                          then live_in_cont
-                                          else emptyLiveInfo)
-                                     (vars_bind rec_body_fvs bind)
+    (bind2, bind_fvs, bind_escs,
+     body2, body_fvs, body_escs)
+       <- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do
+
+          ( bind2, bind_fvs, bind_escs, env_ext)
+                <- vars_bind rec_body_fvs bind
 
           -- Do the body
           extendVarEnvLne env_ext $ do
              (body2, body_fvs, body_escs) <- coreToStgExpr body
-             body_lv_info <- freeVarsToLiveVars body_fvs
 
-             return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
-                     body2, body_fvs, body_escs, getLiveVars body_lv_info)
+             return (bind2, bind_fvs, bind_escs,
+                     body2, body_fvs, body_escs)
 
 
         -- Compute the new let-expression
     let
-        new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+        new_let | let_no_escape = StgLetNoEscape bind2 body2
                 | otherwise     = StgLet bind2 body2
 
         free_in_whole_let
           = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
 
-        live_in_whole_let
-          = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
-
         real_bind_escs = if let_no_escape then
                             bind_escs
                          else
@@ -747,49 +705,43 @@ coreToStgLet let_no_escape bind body = do
     set_of_binders = mkVarSet binders
     binders        = bindersOf bind
 
-    mk_binding bind_lv_info binder rhs
-        = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
-        where
-           live_vars | let_no_escape = addLiveVar bind_lv_info binder
-                     | otherwise     = unitLiveVar binder
-                -- c.f. the invariant on NestedLet
+    mk_binding binder rhs
+        = (binder, LetBound NestedLet (manifestArity rhs))
 
     vars_bind :: FreeVarsInfo           -- Free var info for body of binding
               -> CoreBind
               -> LneM (StgBinding,
                        FreeVarsInfo,
                        EscVarsSet,        -- free vars; escapee vars
-                       LiveInfo,          -- Vars and CAFs live in binding
                        [(Id, HowBound)])  -- extension to environment
 
 
     vars_bind body_fvs (NonRec binder rhs) = do
-        (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
+        (rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs)
         let
-            env_ext_item = mk_binding bind_lv_info binder rhs
+            env_ext_item = mk_binding binder rhs
 
         return (StgNonRec binder rhs2,
-                bind_fvs, escs, bind_lv_info, [env_ext_item])
+                bind_fvs, escs, [env_ext_item])
 
 
     vars_bind body_fvs (Rec pairs)
-      = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
+      = mfix $ \ ~(_, rec_rhs_fvs, _, _) ->
            let
                 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
                 binders = map fst pairs
-                env_ext = [ mk_binding bind_lv_info b rhs
+                env_ext = [ mk_binding b rhs
                           | (b,rhs) <- pairs ]
            in
            extendVarEnvLne env_ext $ do
-              (rhss2, fvss, lv_infos, escss)
-                     <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
+              (rhss2, fvss, escss)
+                     <- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) pairs
               let
                         bind_fvs = unionFVInfos fvss
-                        bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
                         escs     = unionVarSets escss
 
               return (StgRec (binders `zip` rhss2),
-                      bind_fvs, escs, bind_lv_info, env_ext)
+                      bind_fvs, escs, env_ext)
 
 
 is_join_var :: Id -> Bool
@@ -798,37 +750,35 @@ is_join_var :: Id -> Bool
 is_join_var j = occNameString (getOccName j) == "$j"
 
 coreToStgRhs :: FreeVarsInfo      -- Free var info for the scope of the binding
-             -> [Id]
              -> (Id,CoreExpr)
-             -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
+             -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
 
-coreToStgRhs scope_fv_info binders (bndr, rhs) = do
+coreToStgRhs scope_fv_info (bndr, rhs) = do
     (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
-    lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
-    return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs,
-            rhs_fvs, lv_info, rhs_escs)
+    return (mkStgRhs rhs_fvs bndr bndr_info new_rhs,
+            rhs_fvs, rhs_escs)
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
 
-mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
 mkStgRhs = mkStgRhs' con_updateable
   where con_updateable _ _ = False
 
 mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
-            -> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
+            -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
   | StgLam bndrs body <- rhs
   = StgRhsClosure noCCS binder_info
                    (getFVs rhs_fvs)
                    ReEntrant
-                   srt bndrs body
+                   bndrs body
   | StgConApp con args <- unticked_rhs
   , not (con_updateable con args)
   = StgRhsCon noCCS con args
   | otherwise
   = StgRhsClosure noCCS binder_info
                    (getFVs rhs_fvs)
-                   upd_flag srt [] rhs
+                   upd_flag [] rhs
  where
 
     (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
@@ -896,17 +846,10 @@ isPAP env _               = False
 
 newtype LneM a = LneM
     { unLneM :: IdEnv HowBound
-             -> LiveInfo                -- Vars and CAFs live in continuation
              -> a
     }
 
-type LiveInfo = (StgLiveVars,   -- Dynamic live variables;
-                                -- i.e. ones with a nested (non-top-level) binding
-                 CafSet)        -- Static live variables;
-                                -- i.e. top-level variables that are CAFs or refer to them
-
 type EscVarsSet = IdSet
-type CafSet     = IdSet
 
 data HowBound
   = ImportBound         -- Used only as a response to lookupBinding; never
@@ -920,10 +863,7 @@ data HowBound
 
 data LetInfo
   = TopLet              -- top level things
-  | NestedLet LiveInfo  -- For nested things, what is live if this
-                        -- thing is live?  Invariant: the binder
-                        -- itself is always a member of
-                        -- the dynamic set of its own LiveInfo
+  | NestedLet
 
 isLetBound :: HowBound -> Bool
 isLetBound (LetBound _ _) = True
@@ -948,31 +888,10 @@ topLevelBound _                   = False
 -- The set of dynamic live variables is guaranteed ot have no further
 -- let-no-escaped variables in it.
 
-emptyLiveInfo :: LiveInfo
-emptyLiveInfo = (emptyVarSet,emptyVarSet)
-
-unitLiveVar :: Id -> LiveInfo
-unitLiveVar lv = (unitVarSet lv, emptyVarSet)
-
-unitLiveCaf :: Id -> LiveInfo
-unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
-
-addLiveVar :: LiveInfo -> Id -> LiveInfo
-addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
-
-unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
-unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
-
-mkSRT :: LiveInfo -> SRT
-mkSRT (_, cafs) = SRTEntries cafs
-
-getLiveVars :: LiveInfo -> StgLiveVars
-getLiveVars (lvs, _) = lvs
-
 -- The std monad functions:
 
 initLne :: IdEnv HowBound -> LneM a -> a
-initLne env m = unLneM m env emptyLiveInfo
+initLne env m = unLneM m env
 
 
 
@@ -980,11 +899,11 @@ initLne env m = unLneM m env emptyLiveInfo
 {-# INLINE returnLne #-}
 
 returnLne :: a -> LneM a
-returnLne e = LneM $ \_ -> e
+returnLne e = LneM $ \_ -> e
 
 thenLne :: LneM a -> (a -> LneM b) -> LneM b
-thenLne m k = LneM $ \env lvs_cont
-  -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
+thenLne m k = LneM $ \env
+  -> unLneM (k (unLneM m env)) env
 
 instance Functor LneM where
     fmap = liftM
@@ -997,27 +916,19 @@ instance Monad LneM where
     (>>=)  = thenLne
 
 instance MonadFix LneM where
-    mfix expr = LneM $ \env lvs_cont ->
-                       let result = unLneM (expr result) env lvs_cont
+    mfix expr = LneM $ \env ->
+                       let result = unLneM (expr result) env
                        in  result
 
 -- Functions specific to this monad:
 
-getVarsLiveInCont :: LneM LiveInfo
-getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
-
-setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
-setVarsLiveInCont new_lvs_cont expr
-   =    LneM $   \env _lvs_cont
-   -> unLneM expr env new_lvs_cont
-
 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 extendVarEnvLne ids_w_howbound expr
-   =    LneM $   \env lvs_cont
-   -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
+   =    LneM $   \env
+   -> unLneM expr (extendVarEnvList env ids_w_howbound)
 
 lookupVarLne :: Id -> LneM HowBound
-lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
+lookupVarLne v = LneM $ \env -> lookupBinding env v
 
 lookupBinding :: IdEnv HowBound -> Id -> HowBound
 lookupBinding env v = case lookupVarEnv env v of
@@ -1025,32 +936,6 @@ lookupBinding env v = case lookupVarEnv env v of
                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 
 
--- The result of lookupLiveVarsForSet, a set of live variables, is
--- only ever tacked onto a decorated expression. It is never used as
--- the basis of a control decision, which might give a black hole.
-
-freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
-freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
- where
-  freeVarsToLiveVars' _env live_in_cont = live_info
-   where
-    live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
-    lvs_from_fvs = map do_one (allFreeIds fvs)
-
-    do_one (v, how_bound)
-      = case how_bound of
-          ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
-                                                                -- recorded in fvs
-          LetBound TopLet _
-                | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
-                | otherwise                    -> emptyLiveInfo
-
-          LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
-                                                        -- (see the invariant on NestedLet)
-
-          _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
-
-
 -- ---------------------------------------------------------------------------
 -- Free variable information
 -- ---------------------------------------------------------------------------
@@ -1117,11 +1002,6 @@ lookupFVInfo fvs id
                         Nothing         -> noBinderInfo
                         Just (_,_,info) -> info
 
-allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]   -- Both top level and non-top-level Ids
-allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
-      where
-        ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
-
 -- Non-top-level things only, both type variables and ids
 getFVs :: FreeVarsInfo -> [Var]
 getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
@@ -1145,9 +1025,9 @@ check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_e
 check_eq_how_bound _                  _                  = False
 
 check_eq_li :: LetInfo -> LetInfo -> Bool
-check_eq_li (NestedLet _) (NestedLet _) = True
-check_eq_li TopLet        TopLet        = True
-check_eq_li _             _             = False
+check_eq_li NestedLet NestedLet = True
+check_eq_li TopLet    TopLet    = True
+check_eq_li _         _         = False
 
 -- Misc.
 
index a871778..df3c4e5 100644 (file)
@@ -124,10 +124,10 @@ lint_binds_help (binder, rhs)
 
 lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact
 
-lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
   = lintStgExpr expr
 
-lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) $
       addInScopeVars binders $ runMaybeT $ do
         body_ty <- MaybeT $ lintStgExpr expr
@@ -176,7 +176,7 @@ lintStgExpr (StgLet binds body) = do
       addInScopeVars binders $
         lintStgExpr body
 
-lintStgExpr (StgLetNoEscape _ _ binds body) = do
+lintStgExpr (StgLetNoEscape binds body) = do
     binders <- lintStgBinds binds
     addLoc (BodyOfLetRec binders) $
       addInScopeVars binders $
@@ -184,7 +184,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do
 
 lintStgExpr (StgTick _ expr) = lintStgExpr expr
 
-lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
+lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
     _ <- MaybeT $ lintStgExpr scrut
 
     in_scope <- MaybeT $ liftM Just $
index 204e843..1fc8412 100644 (file)
@@ -31,11 +31,8 @@ module StgSyn (
         -- StgOp
         StgOp(..),
 
-        -- SRTs
-        SRT(..),
-
         -- utils
-        stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
+        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
         isDllConApp,
         stgArgType,
         stripStgTicksTop,
@@ -69,7 +66,6 @@ import Type        ( typePrimRep )
 import UniqSet
 import Unique      ( Unique )
 import Util
-import VarSet      ( IdSet, isEmptyVarSet )
 
 {-
 ************************************************************************
@@ -82,8 +78,6 @@ As usual, expressions are interesting; other things are boring. Here
 are the boring things [except note the @GenStgRhs@], parameterised
 with respect to binder and occurrence information (just as in
 @CoreSyn@):
-
-There is one SRT for each group of bindings.
 -}
 
 data GenStgBinding bndr occ
@@ -237,23 +231,8 @@ This has the same boxed/unboxed business as Core case expressions.
         (GenStgExpr bndr occ)
                     -- the thing to examine
 
-        (GenStgLiveVars occ)
-                    -- Live vars of whole case expression,
-                    -- plus everything that happens after the case
-                    -- i.e., those which mustn't be overwritten
-
-        (GenStgLiveVars occ)
-                    -- Live vars of RHSs (plus what happens afterwards)
-                    -- i.e., those which must be saved before eval.
-                    --
-                    -- note that an alt's constructor's
-                    -- binder-variables are NOT counted in the
-                    -- free vars for the alt's RHS
-
         bndr        -- binds the result of evaluating the scrutinee
 
-        SRT         -- The SRT for the continuation
-
         AltType
 
         [GenStgAlt bndr occ]
@@ -358,16 +337,7 @@ And so the code for let(rec)-things:
         (GenStgBinding bndr occ)    -- right hand sides (see below)
         (GenStgExpr bndr occ)       -- body
 
-  | StgLetNoEscape                  -- remember: ``advanced stuff''
-        (GenStgLiveVars occ)        -- Live in the whole let-expression
-                                    -- Mustn't overwrite these stack slots
-                                    -- _Doesn't_ include binders of the let(rec).
-
-        (GenStgLiveVars occ)        -- Live in the right hand sides (only)
-                                    -- These are the ones which must be saved on
-                                    -- the stack if they aren't there already
-                                    -- _Does_ include binders of the let(rec) if recursive.
-
+  | StgLetNoEscape
         (GenStgBinding bndr occ)    -- right hand sides (see below)
         (GenStgExpr bndr occ)       -- body
 
@@ -405,7 +375,6 @@ data GenStgRhs bndr occ
         [occ]                   -- non-global free vars; a list, rather than
                                 -- a set, because order is important
         !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
-        SRT                     -- The SRT reference
         [bndr]                  -- arguments; if empty, then not a function;
                                 -- as above, order is important.
         (GenStgExpr bndr occ)   -- body
@@ -436,24 +405,84 @@ The second flavour of right-hand-side is for constructors (simple but important)
         [GenStgArg occ]  -- args
 
 stgRhsArity :: StgRhs -> Int
-stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)
+stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)
   = ASSERT( all isId bndrs ) length bndrs
   -- The arity never includes type parameters, but they should have gone by now
 stgRhsArity (StgRhsCon _ _ _) = 0
 
-stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
-stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
-stgBindHasCafRefs (StgRec binds)    = any rhsHasCafRefs (map snd binds)
+-- Note [CAF consistency]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
+-- reality.
+--
+-- Specifically, if the RHS mentions any Id that itself is marked
+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
+-- have taken place since then.
+
+topStgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
+topStgBindHasCafRefs (StgNonRec _ rhs)
+  = topRhsHasCafRefs rhs
+topStgBindHasCafRefs (StgRec binds)
+  = any topRhsHasCafRefs (map snd binds)
+
+topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
+topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)
+  = -- See Note [CAF consistency]
+    isUpdatable upd || exprHasCafRefs body
+topRhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+exprHasCafRefs :: GenStgExpr bndr Id -> Bool
+exprHasCafRefs (StgApp f args)
+  = stgIdHasCafRefs f || any stgArgHasCafRefs args
+exprHasCafRefs StgLit{}
+  = False
+exprHasCafRefs (StgConApp _ args)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgOpApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgLam _ body)
+  = exprHasCafRefs body
+exprHasCafRefs (StgCase scrt _ _ alts)
+  = exprHasCafRefs scrt || any altHasCafRefs alts
+exprHasCafRefs (StgLet bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgLetNoEscape bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgTick _ expr)
+  = exprHasCafRefs expr
+
+bindHasCafRefs :: GenStgBinding bndr Id -> Bool
+bindHasCafRefs (StgNonRec _ rhs)
+  = rhsHasCafRefs rhs
+bindHasCafRefs (StgRec binds)
+  = any rhsHasCafRefs (map snd binds)
 
 rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
-rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
-  = isUpdatable upd || nonEmptySRT srt
+rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body)
+  = exprHasCafRefs body
 rhsHasCafRefs (StgRhsCon _ _ args)
   = any stgArgHasCafRefs args
 
+altHasCafRefs :: GenStgAlt bndr Id -> Bool
+altHasCafRefs (_, _, _, rhs) = exprHasCafRefs rhs
+
 stgArgHasCafRefs :: GenStgArg Id -> Bool
-stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
-stgArgHasCafRefs _ = False
+stgArgHasCafRefs (StgVarArg id)
+  = stgIdHasCafRefs id
+stgArgHasCafRefs _
+  = False
+
+stgIdHasCafRefs :: Id -> Bool
+stgIdHasCafRefs id =
+  -- We are looking for occurrences of an Id that is bound at top level, and may
+  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
+  -- imported or defined in this module) are GlobalIds, so the test is easy.
+  isGlobalId id && mayHaveCafRefs (idCafInfo id)
 
 -- Here's the @StgBinderInfo@ type, and its combining op:
 
@@ -494,7 +523,7 @@ Very like in @CoreSyntax@ (except no type-world stuff).
 The type constructor is guaranteed not to be abstract; that is, we can
 see its representation. This is important because the code generator
 uses it to determine return conventions etc. But it's not trivial
-where there's a moduule loop involved, because some versions of a type
+where there's a module loop involved, because some versions of a type
 constructor might not have all the constructors visible. So
 mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
 constructors or literals (which are guaranteed to have the Real McCoy)
@@ -587,34 +616,6 @@ data StgOp
 {-
 ************************************************************************
 *                                                                      *
-\subsubsection[Static Reference Tables]{@SRT@}
-*                                                                      *
-************************************************************************
-
-There is one SRT per top-level function group. Each local binding and
-case expression within this binding group has a subrange of the whole
-SRT, expressed as an offset and length.
-
-In CoreToStg we collect the list of CafRefs at each SRT site, which is later
-converted into the length and offset form by the SRT pass.
--}
-
-data SRT
-  = NoSRT
-  | SRTEntries IdSet
-        -- generated by CoreToStg
-
-nonEmptySRT :: SRT -> Bool
-nonEmptySRT NoSRT           = False
-nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
-
-pprSRT :: SRT -> SDoc
-pprSRT (NoSRT)          = text "_no_srt_"
-pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
-
-{-
-************************************************************************
-*                                                                      *
 \subsection[Stg-pretty-printing]{Pretty-printing}
 *                                                                      *
 ************************************************************************
@@ -719,15 +720,10 @@ pprStgExpr (StgLet bind expr)
   = sep [hang (text "let {") 2 (pprGenStgBinding bind),
            hang (text "} in ") 2 (ppr expr)]
 
-pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
+pprStgExpr (StgLetNoEscape bind expr)
   = sep [hang (text "let-no-escape {")
                 2 (pprGenStgBinding bind),
-           hang (text "} in " <>
-                   ifPprDebug (
-                    nest 4 (
-                      hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
-                             text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss),
-                             char ']'])))
+           hang (text "} in ")
                 2 (ppr expr)]
 
 pprStgExpr (StgTick tickish expr)
@@ -737,17 +733,11 @@ pprStgExpr (StgTick tickish expr)
     else pprStgExpr expr
 
 
-pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
+pprStgExpr (StgCase expr bndr alt_type alts)
   = sep [sep [text "case",
            nest 4 (hsep [pprStgExpr expr,
              ifPprDebug (dcolon <+> ppr alt_type)]),
            text "of", pprBndr CaseBind bndr, char '{'],
-           ifPprDebug (
-           nest 4 (
-             hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
-                    text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss),
-                    text "]; ",
-                    pprMaybeSRT srt])),
            nest 2 (vcat (map pprStgAlt alts)),
            char '}']
 
@@ -780,25 +770,21 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
           => GenStgRhs bndr bdee -> SDoc
 
 -- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
   = hcat [ ppr cc,
            pp_binder_info bi,
            brackets (ifPprDebug (ppr free_var)),
-           text " \\", ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
+           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
 
 -- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
   = sdocWithDynFlags $ \dflags ->
     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
                 pp_binder_info bi,
                 ifPprDebug (brackets (interppSP free_vars)),
-                char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
+                char '\\' <> ppr upd_flag, brackets (interppSP args)])
          4 (ppr body)
 
 pprStgRhs (StgRhsCon cc con args)
   = hcat [ ppr cc,
            space, ppr con, text "! ", brackets (interppSP args)]
-
-pprMaybeSRT :: SRT -> SDoc
-pprMaybeSRT (NoSRT) = empty
-pprMaybeSRT srt     = text "srt:" <> pprSRT srt