experiment towards reducing normal simplifier blowups

idea: erase are coercion terms unless O0 or core linting are enabled

5 files changed, 63 insertions, 2 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2d3e3254ff..cab7c292a3 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -449,6 +449,7 @@ Library
         OccurAnal
         SAT
         SetLevels
+        CoreEraseCoercionProofs
         SimplCore
         SimplEnv
         SimplMonad
diff --git a/compiler/simplCore/CoreEraseCoercionProofs.hs b/compiler/simplCore/CoreEraseCoercionProofs.hs
new file mode 100644
index 0000000000..ca59949d4d
--- /dev/null
+++ b/compiler/simplCore/CoreEraseCoercionProofs.hs
@@ -0,0 +1,48 @@
+module CoreEraseCoercionProofs (eraseCoercionProgram,coreProgramEraseCoercionProofs) where
+
+import GhcPrelude
+
+import CoreSyn
+import HscTypes         ( ModGuts(..) )
+
+import CoreMonad        ( CoreM )
+import DynFlags
+
+{-
+Top-level interface function, @eraseCoercionProgram@.
+
+-}
+
+eraseCoercionProgram :: ModGuts -> CoreM ModGuts
+eraseCoercionProgram pgm@(ModGuts { mg_binds = binds })
+  = do { dflags <- getDynFlags
+         return (pgm { mg_binds = map (coreProgramEraseCoercionProofs dflags) binds })
+        }
+
+coreProgramEraseCoercionProofs :: DynFlags ->CoreProgram -> CoreProgram
+coreProgramEraseCoercionProofs dflags topLevelBindings =
+    if not (gopt Opt_DoCoreLinting dflags) then
+      case  topLevelBindings of
+          NonRec v expr -> NonRec v $  coreExprEraseProof expr
+          Rec bindings -> Rec $ map (\(v,expr)-> (v,coreExprEraseProof expr)) bindings
+      else topLevelBindings
+
+coreExprEraseProof :: Expr b -> Expr b
+coreExprEraseProof e@(Var   Id) = e
+coreExprEraseProof e@(Lit   Literal) = e
+coreExprEraseProof (App   f  e)  = App (coreExprEraseProof f) (coreExprEraseProof)
+coreExprEraseProof (Lam   v e) =  Lam v $ coreExprEraseProof e
+coreExprEraseProof (Let   binders bod) = Let (eraseBinders binder) (coreExprEraseProof bod)
+coreExprEraseProof (Case  scrut v ty alts  )=
+    Case (coreExprEraseProof scrut) v ty (map eraseAltPfs alts)
+coreExprEraseProof (Cast  e _) = Cast (coreExprEraseProof e) ErasedCoercion
+coreExprEraseProof (Tick  tick e)= Tick tick (coreExprEraseProof e)
+coreExprEraseProof (Type  t) = Type t
+coreExprEraseProof (Coercion _)= Coercion ErasedCoercion
+
+eraseAltPfs :: Alt b -> Alt b
+eraseAltPfs (con, vars, body) = (con,vars,coreExprEraseProof body)
+
+eraseBinders :: Bind b -> Bind b
+eraseBinders(NonRec var rhs)=  NonRec var $ coreExprEraseProof rhs
+eraseBinders (Rec  binders) = Rec $ map (\(v,e)-> (v,coreExprEraseProof e)) binders
\ No newline at end of file
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 04898921de..742ae39bf5 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -122,6 +122,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreTidy
   | CorePrep
   | CoreOccurAnal
+  | CoreEraseCoercionEvidence --
 
 instance Outputable CoreToDo where
   ppr (CoreDoSimplify _ _)     = text "Simplifier"
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 19465082dc..e3f4dbac3e 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -48,6 +48,7 @@ import DmdAnal          ( dmdAnalProgram )
 import CallArity        ( callArityAnalProgram )
 import Exitify          ( exitifyProgram )
 import WorkWrap         ( wwTopBinds )
+import CoreEraseCoercionProofs (eraseCoercionProgram,coreProgramEraseCoercionProofs)
 import SrcLoc
 import Util
 import Module
@@ -121,6 +122,7 @@ getCoreToDo dflags
     phases        = simplPhases        dflags
     max_iter      = maxSimplIterations dflags
     rule_check    = ruleCheck          dflags
+
     call_arity    = gopt Opt_CallArity                    dflags
     exitification = gopt Opt_Exitification                dflags
     strictness    = gopt Opt_Strictness                   dflags
@@ -457,6 +459,9 @@ doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        specConstrProgram
 
+doCorePass CoreEraseCoercionEvidence = {-# SCC "EraseCoercionEvidence" #-}
+                                       doEraseCoercions
+
 doCorePass CoreDoPrintCore              = observe   printCore
 doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
 doCorePass CoreDoNothing                = return
@@ -464,6 +469,7 @@ doCorePass (CoreDoPasses passes)        = runCorePasses passes
 
 doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
 
+
 doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)
 doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)
 doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)
@@ -724,7 +730,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
            if isZeroSimplCount counts1 then
                 return ( "Simplifier reached fixed point", iteration_no
                        , totalise (counts1 : counts_so_far)  -- Include "free" ticks
-                       , guts { mg_binds = binds1, mg_rules = rules1 } )
+                       , guts { mg_binds =coreProgramEraseCoercionProofs dflags binds1
+                                ,mg_rules = rules1 } )
            else do {
                 -- Short out indirections
                 -- We do this *after* at least one run of the simplifier
@@ -741,7 +748,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
            lintPassResult hsc_env pass binds2 ;
 
                 -- Loop
-           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
+           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far)
+                  (coreProgramEraseCoercionProofs dflags binds2) rules1
            } }
       | otherwise = panic "do_iteration"
       where
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index be2f74c731..926b066260 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -1068,6 +1068,8 @@ data Coercion
 
   | HoleCo CoercionHole              -- ^ See Note [Coercion holes]
                                      -- Only present during typechecking
+  | ErasedCoercion -- ^ optimization hack because cast terms blowup fusion heavy
+                   -- code, implied whenever corelint isn't enabled
   deriving Data.Data
 
 type CoercionN = Coercion       -- always nominal
@@ -1672,6 +1674,7 @@ coercionSize (ForAllCo _ h co)   = 1 + coercionSize co + coercionSize h
 coercionSize (FunCo _ co1 co2)   = 1 + coercionSize co1 + coercionSize co2
 coercionSize (CoVarCo _)         = 1
 coercionSize (HoleCo _)          = 1
+coercionSize ErasedCoercion      = 1
 coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)
 coercionSize (UnivCo p _ t1 t2)  = 1 + provSize p + typeSize t1 + typeSize t2
 coercionSize (SymCo co)          = 1 + coercionSize co