put coqPassCoreToCore on the CoreM monad, greatly simplify Desugar.lhs

[ghc-hetmet.git] / compiler / simplCore / SimplCore.lhs

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 581ac41..59aba4b 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -20,7 +20,7 @@ import OccurAnal      ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
-import SimplUtils      ( simplEnvForGHCi )
+import SimplUtils      ( simplEnvForGHCi, activeRule )
 import SimplEnv
 import SimplMonad
 import CoreMonad
@@ -29,7 +29,7 @@ import FloatIn                ( floatInwards )
 import FloatOut                ( floatOutwards )
 import FamInstEnv
 import Id
-import BasicTypes       ( CompilerPhase, isDefaultInlinePragma )
+import BasicTypes
 import VarSet
 import VarEnv
 import LiberateCase    ( liberateCase )
@@ -123,8 +123,8 @@ doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        specConstrProgram
 
-doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
-                                       vectorise be
+doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
+                                       vectorise
 
 doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
 doCorePass CoreDoPrintCore              = observe   printCore
@@ -211,7 +211,7 @@ simplifyExpr dflags expr
        ; us <-  mkSplitUniqSupply 's'
 
        ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                simplExprGently simplEnvForGHCi expr
+                                simplExprGently (simplEnvForGHCi dflags) expr
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                        (pprCoreExpr expr')
@@ -307,7 +307,7 @@ simplifyPgmIO :: CoreToDo
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
 
-simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
+simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
               hsc_env us hpt_rule_base 
               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
@@ -323,9 +323,11 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
        ; return (counts_out, guts')
     }
   where
-    dflags              = hsc_dflags hsc_env
-    dump_phase          = dumpSimplPhase dflags mode
-    sw_chkr     = isAmongSimpl switches
+    dflags      = hsc_dflags hsc_env
+    dump_phase  = dumpSimplPhase dflags mode
+    simpl_env   = mkSimplEnv mode
+    active_rule = activeRule dflags simpl_env
+
     do_iteration :: UniqSupply
                  -> Int                 -- Counts iterations
                 -> [SimplCount] -- Counts from earlier iterations, reversed
@@ -354,10 +356,18 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
       -- space usage, especially with -O.  JRS, 000620.
       | let sz = coreBindsSize binds in sz == sz
       = do {
-               -- Occurrence analysis
-          let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
-          Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
-                    (pprCoreBindings tagged_binds);
+                -- Occurrence analysis
+           let {   -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
+                   -- that the right-hand sides of vectorisation declarations are taken into 
+                   -- account during occurence analysis.
+                 maybeVects   = case sm_phase mode of
+                                  InitialPhase -> mg_vect_decls guts
+                                  _            -> []
+               ; tagged_binds = {-# SCC "OccAnal" #-} 
+                     occurAnalysePgm active_rule rules maybeVects binds 
+               } ;
+           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+                     (pprCoreBindings tagged_binds);
 
                -- Get any new rules, and extend the rule base
                -- See Note [Overall plumbing for rules] in Rules.lhs
@@ -368,7 +378,6 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
           eps <- hscEPS hsc_env ;
           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
                ; rule_base2 = extendRuleBaseList rule_base1 rules
-               ; simpl_env  = mkSimplEnv sw_chkr mode
                ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;