Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Use a custom dead-code analyser instead of calling the occurrence ana…

…lyser.

In CorePrep we used to call the occurrence analyser to drop dead code
(see Note [Dead code in CorePrep]), but the occurrence analyser
sometimes introduces new let bindings for case binders.  This was
leading to the bug in #5433: the let binding introduced was for an
unlifted value, and the code generator is not expecting to see let
bindings of unlifted values (CorePrep is supposed to eliminate them).
We don't want this let binding anyway, so instead of using the
occurrence analyser here we have a simple custom dead-code analyser.
  • Loading branch information...
commit 3572c11958bf77e0797a190efab68cf80895f2ac 1 parent 984419f
Simon Marlow simonmar authored
Showing with 74 additions and 16 deletions.
  1. +74 −16 compiler/coreSyn/CorePrep.lhs
90 compiler/coreSyn/CorePrep.lhs
View
@@ -5,6 +5,7 @@
Core pass to saturate constructors and PrimOps
\begin{code}
+{-# LANGUAGE BangPatterns #-}
module CorePrep (
corePrepPgm, corePrepExpr
) where
@@ -19,7 +20,6 @@ import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
import CoreSubst
import MkCore
-import OccurAnal ( occurAnalyseExpr )
import Type
import Literal
import Coercion
@@ -288,23 +288,29 @@ After specialisation and SpecConstr, we would get something like this:
g$Bool_True_Just = ...
g$Unit_Unit_Just = ...
-Note that the g$Bool and g$Unit functions are actually dead code: they are only kept
-alive by the occurrence analyser because they are referred to by the rules of g,
-which is being kept alive by the fact that it is used (unspecialised) in the returned pair.
+Note that the g$Bool and g$Unit functions are actually dead code: they
+are only kept alive by the occurrence analyser because they are
+referred to by the rules of g, which is being kept alive by the fact
+that it is used (unspecialised) in the returned pair.
-However, at the CorePrep stage there is no way that the rules for g will ever fire,
-and it really seems like a shame to produce an output program that goes to the trouble
-of allocating a closure for the unreachable g$Bool and g$Unit functions.
+However, at the CorePrep stage there is no way that the rules for g
+will ever fire, and it really seems like a shame to produce an output
+program that goes to the trouble of allocating a closure for the
+unreachable g$Bool and g$Unit functions.
The way we fix this is to:
* In cloneBndr, drop all unfoldings/rules
- * In deFloatTop, run the occurrence analyser on each top-level RHS to drop
- the dead local bindings
-
-The reason we don't just OccAnal the whole output of CorePrep is that the tidier
-ensures that all top-level binders are GlobalIds, so they don't show up in the free
-variables any longer. So if you run the occurrence analyser on the output of CoreTidy
-(or later) you e.g. turn this program:
+ * In deFloatTop, run a simple dead code analyser on each top-level RHS to drop
+ the dead local bindings. (we used to run the occurrence analyser to do
+ this job, but the occurrence analyser sometimes introduces new let
+ bindings for case binders, which lead to the bug in #5433, hence we
+ now have a special-purpose dead code analyser).
+
+The reason we don't just OccAnal the whole output of CorePrep is that
+the tidier ensures that all top-level binders are GlobalIds, so they
+don't show up in the free variables any longer. So if you run the
+occurrence analyser on the output of CoreTidy (or later) you e.g. turn
+this program:
Rec {
f = ... f ...
@@ -1006,8 +1012,60 @@ deFloatTop (Floats _ floats)
get b _ = pprPanic "corePrepPgm" (ppr b)
-- See Note [Dead code in CorePrep]
- occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e)
- occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
+ occurAnalyseRHSs (NonRec x e) = NonRec x (fst (dropDeadCode e))
+ occurAnalyseRHSs (Rec xes) = Rec [ (x, fst (dropDeadCode e))
+ | (x, e) <- xes]
+
+---------------------------------------------------------------------------
+-- Simple dead-code analyser, see Note [Dead code in CorePrep]
+
+dropDeadCode :: CoreExpr -> (CoreExpr, VarSet)
+dropDeadCode (Var v)
+ = (Var v, if isLocalId v then unitVarSet v else emptyVarSet)
+dropDeadCode (App fun arg)
+ = (App fun' arg', fun_fvs `unionVarSet` arg_fvs)
+ where !(fun', fun_fvs) = dropDeadCode fun
+ !(arg', arg_fvs) = dropDeadCode arg
+dropDeadCode (Lam v e)
+ = (Lam v e', delVarSet fvs v)
+ where !(e', fvs) = dropDeadCode e
+dropDeadCode (Let (NonRec v rhs) body)
+ | v `elemVarSet` body_fvs
+ = (Let (NonRec v rhs') body', rhs_fvs `unionVarSet` (body_fvs `delVarSet` v))
+ | otherwise
+ = (body', body_fvs) -- drop the dead let bind!
+ where !(body', body_fvs) = dropDeadCode body
+ !(rhs', rhs_fvs) = dropDeadCode rhs
+dropDeadCode (Let (Rec prs) body)
+ | any (`elemVarSet` all_fvs) bndrs
+ -- approximation: strictly speaking we should do SCC analysis here,
+ -- but for simplicity we just look to see whether any of the binders
+ -- is used and drop the entire group if all are unused.
+ = (Let (Rec (zip bndrs rhss')) body', all_fvs `delVarSetList` bndrs)
+ | otherwise
+ = (body', body_fvs) -- drop the dead let bind!
+ where !(body', body_fvs) = dropDeadCode body
+ !(bndrs, rhss) = unzip prs
+ !(rhss', rhs_fvss) = unzip (map dropDeadCode rhss)
+ all_fvs = unionVarSets (body_fvs : rhs_fvss)
+
+dropDeadCode (Case scrut bndr t alts)
+ = (Case scrut' bndr t alts', scrut_fvs `unionVarSet` alts_fvs)
+ where !(scrut', scrut_fvs) = dropDeadCode scrut
+ !(alts', alts_fvs) = dropDeadCodeAlts alts
+dropDeadCode (Cast e c)
+ = (Cast e' c, fvs)
+ where !(e', fvs) = dropDeadCode e
+dropDeadCode (Note n e)
+ = (Note n e', fvs)
+ where !(e', fvs) = dropDeadCode e
+dropDeadCode e = (e, emptyVarSet) -- Lit, Type, Coercion
+
+dropDeadCodeAlts :: [CoreAlt] -> ([CoreAlt], VarSet)
+dropDeadCodeAlts alts = (alts', unionVarSets fvss)
+ where !(alts', fvss) = unzip (map do_alt alts)
+ do_alt (c, vs, e) = ((c,vs,e'), fvs `delVarSetList` vs)
+ where !(e', fvs) = dropDeadCode e
-------------------------------------------
canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
Please sign in to comment.
Something went wrong with that request. Please try again.