Remove StgBinderInfo and related computation in CoreToStg

- The StgBinderInfo type was never used in the code gen, so the type, related
  computation in CoreToStg, and some comments about it are removed. See #15770
  for more details.

- Simplified CoreToStg after removing the StgBinderInfo computation: removed
  StgBinderInfo arguments and mfix stuff.

The StgBinderInfo values were not used in the code gen, but I still run nofib
just to make sure: 0.0% change in allocations and binary sizes.

Test Plan: Validated locally

Reviewers: simonpj, simonmar, bgamari, sgraf

Reviewed By: sgraf

Subscribers: AndreasK, sgraf, rwbarton, carter

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

3 files changed, 44 insertions, 144 deletions

diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 8275564448..12940753f9 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -118,19 +118,6 @@ import Control.Monad (liftM, ap)
 --
 -- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki.
 
--- Note [Collecting live CAF info]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- In this pass we also collect information on which CAFs are live.
---
--- A top-level Id has CafInfo, which is
---
---         - MayHaveCafRefs, if it may refer indirectly to
---           one or more CAFs, or
---         - NoCafRefs if it definitely doesn't
---
--- The CafInfo has already been calculated during the CoreTidy pass.
---
 -- Note [What is a non-escaping let]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
@@ -282,7 +269,7 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs)
 
         (stg_rhs, fvs', ccs') =
             initCts env $
-              coreToTopStgRhs dflags ccs this_mod body_fvs (id,rhs)
+              coreToTopStgRhs dflags ccs this_mod (id,rhs)
 
         bind = StgTopLifted $ StgNonRec id stg_rhs
     in
@@ -308,7 +295,7 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs)
           = initCts env' $ do
                mapAccumLM (\(fvs, ccs) rhs -> do
                             (rhs', fvs', ccs') <-
-                              coreToTopStgRhs dflags ccs this_mod body_fvs rhs
+                              coreToTopStgRhs dflags ccs this_mod rhs
                             return ((fvs' `unionFVInfo` fvs, ccs'), rhs'))
                           (body_fvs, ccs)
                           pairs
@@ -338,15 +325,14 @@ coreToTopStgRhs
         :: DynFlags
         -> CollectedCCs
         -> Module
-        -> FreeVarsInfo         -- Free var info for the scope of the binding
         -> (Id,CoreExpr)
         -> CtsM (StgRhs, FreeVarsInfo, CollectedCCs)
 
-coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs)
+coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
   = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs
 
        ; let (stg_rhs, ccs') =
-               mkTopStgRhs dflags this_mod ccs rhs_fvs bndr bndr_info new_rhs
+               mkTopStgRhs dflags this_mod ccs rhs_fvs bndr new_rhs
              stg_arity =
                stgRhsArity stg_rhs
 
@@ -354,8 +340,6 @@ coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs)
                  rhs_fvs,
                  ccs') }
   where
-    bndr_info = lookupFVInfo scope_fv_info bndr
-
         -- It's vital that the arity on a top-level Id matches
         -- the arity of the generated STG binding, else an importing
         -- module will use the wrong calling convention
@@ -558,8 +542,7 @@ coreToStgApp _ f args ticks = do
 
     let
         n_val_args       = valArgCount args
-        not_letrec_bound = not (isLetBound how_bound)
-        fun_fvs = singletonFVInfo f how_bound fun_occ
+        fun_fvs = singletonFVInfo f how_bound
             -- e.g. (f :: a -> int) (x :: a)
             -- Here the free variables are "f", "x" AND the type variable "a"
             -- coreToStgArgs will deal with the arguments recursively
@@ -574,11 +557,6 @@ coreToStgApp _ f args ticks = do
         f_arity   = stgArity f how_bound
         saturated = f_arity <= n_val_args
 
-        fun_occ
-         | not_letrec_bound         = noBinderInfo      -- Uninteresting variable
-         | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
-         | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk
-
         res_ty = exprType (mkApps (Var f) args)
         app = case idDetails f of
                 DataConWorkId dc
@@ -612,8 +590,6 @@ coreToStgApp _ f args ticks = do
         fvs
      )
 
-
-
 -- ---------------------------------------------------------------------------
 -- Argument lists
 -- This is the guy that turns applications into A-normal form
@@ -686,10 +662,10 @@ coreToStgLet
 coreToStgLet bind body = do
     (bind2, bind_fvs,
      body2, body_fvs)
-       <- mfix $ \ ~(_, _, _, rec_body_fvs) -> do
+       <- do
 
           ( bind2, bind_fvs, env_ext)
-                <- vars_bind rec_body_fvs bind
+                <- vars_bind bind
 
           -- Do the body
           extendVarEnvCts env_ext $ do
@@ -698,7 +674,6 @@ coreToStgLet bind body = do
              return (bind2, bind_fvs,
                      body2, body_fvs)
 
-
         -- Compute the new let-expression
     let
         new_let | isJoinBind bind = StgLetNoEscape bind2 body2
@@ -717,59 +692,51 @@ coreToStgLet bind body = do
     mk_binding binder rhs
         = (binder, LetBound NestedLet (manifestArity rhs))
 
-    vars_bind :: FreeVarsInfo           -- Free var info for body of binding
-              -> CoreBind
+    vars_bind :: CoreBind
               -> CtsM (StgBinding,
                        FreeVarsInfo,
                        [(Id, HowBound)])  -- extension to environment
 
-
-    vars_bind body_fvs (NonRec binder rhs) = do
-        (rhs2, bind_fvs) <- coreToStgRhs body_fvs (binder,rhs)
+    vars_bind (NonRec binder rhs) = do
+        (rhs2, bind_fvs) <- coreToStgRhs (binder,rhs)
         let
             env_ext_item = mk_binding binder rhs
 
         return (StgNonRec binder rhs2,
                 bind_fvs, [env_ext_item])
 
-
-    vars_bind body_fvs (Rec pairs)
-      = mfix $ \ ~(_, rec_rhs_fvs, _) ->
-           let
-                rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+    vars_bind (Rec pairs)
+      =    let
                 binders = map fst pairs
                 env_ext = [ mk_binding b rhs
                           | (b,rhs) <- pairs ]
            in
            extendVarEnvCts env_ext $ do
               (rhss2, fvss)
-                     <- mapAndUnzipM (coreToStgRhs rec_scope_fvs) pairs
+                     <- mapAndUnzipM coreToStgRhs pairs
               let
                         bind_fvs = unionFVInfos fvss
 
               return (StgRec (binders `zip` rhss2),
                       bind_fvs, env_ext)
 
-coreToStgRhs :: FreeVarsInfo      -- Free var info for the scope of the binding
-             -> (Id,CoreExpr)
+coreToStgRhs :: (Id,CoreExpr)
              -> CtsM (StgRhs, FreeVarsInfo)
 
-coreToStgRhs scope_fv_info (bndr, rhs) = do
+coreToStgRhs (bndr, rhs) = do
     (new_rhs, rhs_fvs) <- coreToStgExpr rhs
-    return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, rhs_fvs)
-  where
-    bndr_info = lookupFVInfo scope_fv_info bndr
+    return (mkStgRhs rhs_fvs bndr new_rhs, rhs_fvs)
 
 -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
 -- appended to `CollectedCCs` argument.
 mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
-            -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr
+            -> FreeVarsInfo -> Id -> StgExpr
             -> (StgRhs, CollectedCCs)
 
-mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
+mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
   | StgLam bndrs body <- rhs
   = -- StgLam can't have empty arguments, so not CAF
-    ( StgRhsClosure dontCareCCS binder_info
+    ( StgRhsClosure dontCareCCS
                     (getFVs rhs_fvs)
                     ReEntrant
                     (toList bndrs) body
@@ -785,13 +752,13 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
 
   -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
   | gopt Opt_AutoSccsOnIndividualCafs dflags
-  = ( StgRhsClosure caf_ccs binder_info
+  = ( StgRhsClosure caf_ccs
                     (getFVs rhs_fvs)
                     upd_flag [] rhs
     , collectCC caf_cc caf_ccs ccs )
 
   | otherwise
-  = ( StgRhsClosure all_cafs_ccs binder_info
+  = ( StgRhsClosure all_cafs_ccs
                     (getFVs rhs_fvs)
                     upd_flag [] rhs
     , ccs )
@@ -816,17 +783,17 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
 
 -- Generate a non-top-level RHS. Cost-centre is always currentCCS,
 -- see Note [Cost-centre initialzation plan].
-mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs rhs_fvs bndr binder_info rhs
+mkStgRhs :: FreeVarsInfo -> Id -> StgExpr -> StgRhs
+mkStgRhs rhs_fvs bndr rhs
   | StgLam bndrs body <- rhs
-  = StgRhsClosure currentCCS binder_info
+  = StgRhsClosure currentCCS
                   (getFVs rhs_fvs)
                   ReEntrant
                   (toList bndrs) body
 
   | isJoinId bndr -- must be a nullary join point
   = ASSERT(idJoinArity bndr == 0)
-    StgRhsClosure currentCCS binder_info
+    StgRhsClosure currentCCS
                   (getFVs rhs_fvs)
                   ReEntrant -- ignored for LNE
                   [] rhs
@@ -835,7 +802,7 @@ mkStgRhs rhs_fvs bndr binder_info rhs
   = StgRhsCon currentCCS con args
 
   | otherwise
-  = StgRhsClosure currentCCS binder_info
+  = StgRhsClosure currentCCS
                   (getFVs rhs_fvs)
                   upd_flag [] rhs
   where
@@ -924,10 +891,6 @@ data LetInfo
   | NestedLet
   deriving (Eq)
 
-isLetBound :: HowBound -> Bool
-isLetBound (LetBound _ _) = True
-isLetBound _              = False
-
 topLevelBound :: HowBound -> Bool
 topLevelBound ImportBound         = True
 topLevelBound (LetBound TopLet _) = True
@@ -974,11 +937,6 @@ instance Applicative CtsM where
 instance Monad CtsM where
     (>>=)  = thenCts
 
-instance MonadFix CtsM where
-    mfix expr = CtsM $ \env ->
-                       let result = unCtsM (expr result) env
-                       in  result
-
 -- Functions specific to this monad:
 
 extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
@@ -1007,7 +965,7 @@ getAllCAFsCC this_mod =
 -- Free variable information
 -- ---------------------------------------------------------------------------
 
-type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
+type FreeVarsInfo = VarEnv (Var, HowBound)
         -- The Var is so we can gather up the free variables
         -- as a set.
         --
@@ -1017,31 +975,16 @@ type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
         --            Imported Ids without CAF refs are simply
         --            not put in the FreeVarsInfo for an expression.
         --            See singletonFVInfo and freeVarsToLiveVars
-        --
-        -- StgBinderInfo records how it occurs; notably, we
-        -- are interested in whether it only occurs in saturated
-        -- applications, because then we don't need to build a
-        -- curried version.
-        -- If f is mapped to noBinderInfo, that means
-        -- that f *is* mentioned (else it wouldn't be in the
-        -- IdEnv at all), but perhaps in an unsaturated applications.
-        --
-        -- All case/lambda-bound things are also mapped to
-        -- noBinderInfo, since we aren't interested in their
-        -- occurrence info.
-        --
-        -- For ILX we track free var info for type variables too;
-        -- hence VarEnv not IdEnv
 
 emptyFVInfo :: FreeVarsInfo
 emptyFVInfo = emptyVarEnv
 
-singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
+singletonFVInfo :: Id -> HowBound -> FreeVarsInfo
 -- Don't record non-CAF imports at all, to keep free-var sets small
-singletonFVInfo id ImportBound info
-   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
+singletonFVInfo id ImportBound
+   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound)
    | otherwise                     = emptyVarEnv
-singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
+singletonFVInfo id how_bound = unitVarEnv id (id, how_bound)
 
 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
@@ -1060,29 +1003,20 @@ minusFVBinder v fv = fv `delVarEnv` v
 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id)
 
-lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
--- Find how the given Id is used.
--- Externally visible things may be used any old how
-lookupFVInfo fvs id
-  | isExternalName (idName id) = noBinderInfo
-  | otherwise = case lookupVarEnv fvs id of
-                        Nothing         -> noBinderInfo
-                        Just (_,_,info) -> info
-
 -- Non-top-level things only, both type variables and ids
 getFVs :: FreeVarsInfo -> [Var]
-getFVs fvs = [id | (id, how_bound, _) <- nonDetEltsUFM fvs,
+getFVs fvs = [id | (id, how_bound) <- nonDetEltsUFM fvs,
   -- It's OK to use nonDetEltsUFM here because we're not aiming for
   -- bit-for-bit determinism.
   -- See Note [Unique Determinism and code generation]
                     not (topLevelBound how_bound) ]
 
-plusFVInfo :: (Var, HowBound, StgBinderInfo)
-           -> (Var, HowBound, StgBinderInfo)
-           -> (Var, HowBound, StgBinderInfo)
-plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
+plusFVInfo :: (Var, HowBound)
+           -> (Var, HowBound)
+           -> (Var, HowBound)
+plusFVInfo (id1,hb1) (id2,hb2)
   = ASSERT(id1 == id2 && hb1 == hb2)
-    (id1, hb1, combineStgBinderInfo info1 info2)
+    (id1, hb1)
 
 -- Misc.
 
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 58f14a1b3f..35a498f368 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -116,10 +116,10 @@ lint_binds_help (binder, rhs)
 
 lintStgRhs :: StgRhs -> LintM ()
 
-lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ [] expr)
   = lintStgExpr expr
 
-lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) $
       addInScopeVars binders $
         lintStgExpr expr
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index eb905f7456..7d347f4865 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -19,10 +19,6 @@ module StgSyn (
 
         UpdateFlag(..), isUpdatable,
 
-        StgBinderInfo,
-        noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
-        combineStgBinderInfo,
-
         -- a set of synonyms for the most common (only :-) parameterisation
         StgArg,
         StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
@@ -393,7 +389,6 @@ flavour is for closures:
 data GenStgRhs bndr occ
   = StgRhsClosure
         CostCentreStack         -- CCS to be attached (default is CurrentCCS)
-        StgBinderInfo           -- Info about how this binder is used (see below)
         [occ]                   -- non-global free vars; a list, rather than
                                 -- a set, because order is important
         !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
@@ -428,7 +423,7 @@ 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
@@ -455,7 +450,7 @@ topStgBindHasCafRefs StgTopStringLit{}
   = False
 
 topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
-topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)
+topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
   = -- See Note [CAF consistency]
     isUpdatable upd || exprHasCafRefs body
 topRhsHasCafRefs (StgRhsCon _ _ args)
@@ -488,7 +483,7 @@ bindHasCafRefs (StgRec binds)
   = any rhsHasCafRefs (map snd binds)
 
 rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
-rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body)
+rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
   = exprHasCafRefs body
 rhsHasCafRefs (StgRhsCon _ _ args)
   = any stgArgHasCafRefs args
@@ -509,33 +504,6 @@ stgIdHasCafRefs id =
   -- 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:
-
-data StgBinderInfo
-  = NoStgBinderInfo
-  | SatCallsOnly        -- All occurrences are *saturated* *function* calls
-                        -- This means we don't need to build an info table and
-                        -- slow entry code for the thing
-                        -- Thunks never get this value
-
-noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
-noBinderInfo = NoStgBinderInfo
-stgUnsatOcc  = NoStgBinderInfo
-stgSatOcc    = SatCallsOnly
-
-satCallsOnly :: StgBinderInfo -> Bool
-satCallsOnly SatCallsOnly    = True
-satCallsOnly NoStgBinderInfo = False
-
-combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
-combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
-combineStgBinderInfo _            _            = NoStgBinderInfo
-
---------------
-pp_binder_info :: StgBinderInfo -> SDoc
-pp_binder_info NoStgBinderInfo = empty
-pp_binder_info SatCallsOnly    = text "sat-only"
-
 {-
 ************************************************************************
 *                                                                      *
@@ -818,19 +786,17 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
           => GenStgRhs bndr bdee -> SDoc
 
 -- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure cc [free_var] upd_flag [{-no args-}] (StgApp func []))
   = sdocWithDynFlags $ \dflags ->
     hsep [ ppr cc,
-           pp_binder_info bi,
            if not $ gopt Opt_SuppressStgFreeVars dflags
              then brackets (ppr free_var) else empty,
            text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
 
 -- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
+pprStgRhs (StgRhsClosure cc free_vars upd_flag args body)
   = sdocWithDynFlags $ \dflags ->
     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
-                pp_binder_info bi,
                 if not $ gopt Opt_SuppressStgFreeVars dflags
                   then brackets (interppSP free_vars) else empty,
                 char '\\' <> ppr upd_flag, brackets (interppSP args)])