[project @ 2003-08-20 18:48:20 by sof]

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

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 9acfd81..be781e6 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -14,8 +14,7 @@ import CmdLineOpts    ( CoreToDo(..), SimplifierSwitch(..),
                        )
 import CoreSyn
 import CoreFVs         ( ruleRhsFreeVars )
-import HscTypes                ( PersistentCompilerState(..), ExternalPackageState(..),
-                         HscEnv(..), GhciMode(..),
+import HscTypes                ( HscEnv(..), GhciMode(..),
                          ModGuts(..), ModGuts, Avails, availsToNameSet, 
                          PackageRuleBase, HomePackageTable, ModDetails(..),
                          HomeModInfo(..)
@@ -43,7 +42,6 @@ import LiberateCase   ( liberateCase )
 import SAT             ( doStaticArgs )
 import Specialise      ( specProgram)
 import SpecConstr      ( specConstrProgram)
-import UsageSPInf       ( doUsageSPInf )
 import DmdAnal         ( dmdAnalPgm )
 import WorkWrap                ( wwTopBinds )
 #ifdef OLD_STRICTNESS
@@ -67,11 +65,11 @@ import List             ( partition )
 
 \begin{code}
 core2core :: HscEnv
-         -> PersistentCompilerState
+         -> PackageRuleBase
          -> ModGuts
          -> IO ModGuts
 
-core2core hsc_env pcs 
+core2core hsc_env pkg_rule_base
          mod_impl@(ModGuts { mg_exports = exports, 
                              mg_binds = binds_in, 
                              mg_rules = rules_in })
@@ -80,7 +78,6 @@ core2core hsc_env pcs
            hpt           = hsc_HPT hsc_env
            ghci_mode     = hsc_mode hsc_env
            core_todos    = dopt_CoreToDo dflags
-           pkg_rule_base = eps_rule_base (pcs_EPS pcs) -- Rule-base accumulated from imported packages
 
        us <-  mkSplitUniqSupply 's'
        let (cp_us, ru_us) = splitUniqSupply us
@@ -118,7 +115,7 @@ simplifyExpr dflags expr
 
        ; us <-  mkSplitUniqSupply 's'
 
-       ; let env              = emptySimplEnv (SimplPhase 0) [] emptyVarSet
+       ; let env              = emptySimplEnv SimplGently [] emptyVarSet
              (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
 
        ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
@@ -173,8 +170,6 @@ doCorePass dfs rb us binds CoreDoOldStrictness
 #endif
 doCorePass dfs rb us binds CoreDoPrintCore             
    = _scc_ "PrintCore"     noStats dfs (printCore binds)
-doCorePass dfs rb us binds CoreDoUSPInf             
-   = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
 doCorePass dfs rb us binds CoreDoGlomBinds             
    = noStats dfs (glomBinds dfs binds)
 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
@@ -362,6 +357,11 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 --     alone leaves tons of crud.
 -- Used (a) for user expressions typed in at the interactive prompt
 --     (b) the LHS and RHS of a RULE
+--
+-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
+-- enforce that; it just simplifies the expression twice
+
 simplExprGently env expr
   = simplExpr env (occurAnalyseGlobalExpr expr)        `thenSmpl` \ expr1 ->
     simplExpr env (occurAnalyseGlobalExpr expr1)
@@ -455,6 +455,23 @@ simplifyPgm dflags rule_base
     max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
  
     iteration us iteration_no counts binds
+       -- iteration_no is the number of the iteration we are
+       -- about to begin, with '1' for the first
+      | iteration_no > max_iterations  -- Stop if we've run out of iterations
+      = do {
+#ifdef DEBUG
+           if  max_iterations > 2 then
+               hPutStr stderr ("NOTE: Simplifier still going after " ++ 
+                               show max_iterations ++ 
+                               " iterations; bailing out.\n")
+           else 
+               return ();
+#endif
+               -- Subtract 1 from iteration_no to get the
+               -- number of iterations we actually completed
+           return ("Simplifier baled out", iteration_no - 1, counts, binds)
+       }
+
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.
       | let sz = coreBindsSize binds in sz == sz
@@ -473,7 +490,7 @@ simplifyPgm dflags rule_base
                --      t = initSmpl ...
                --      counts' = snd t
                --   in
-               --      case t of {(_,counts') -> if counts'=0 then ...
+               --      case t of {(_,counts') -> if counts'=0 then ... }
                -- So the conditional didn't force counts', because the
                -- selection got duplicated.  Sigh!
           case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
@@ -496,27 +513,12 @@ simplifyPgm dflags rule_base
 
                -- Dump the result of this iteration
           dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
-                    (pprSimplCount counts') ;
+                        (pprSimplCount counts') ;
 
           endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
 
-               -- Stop if we've run out of iterations
-          if iteration_no == max_iterations then
-               do {
-#ifdef DEBUG
-                   if  max_iterations > 2 then
-                           hPutStr stderr ("NOTE: Simplifier still going after " ++ 
-                                   show max_iterations ++ 
-                                   " iterations; bailing out.\n")
-                   else 
-#endif
-                       return ();
-
-                   return ("Simplifier baled out", iteration_no, all_counts, binds')
-               }
-
-               -- Else loop
-          else iteration us2 (iteration_no + 1) all_counts binds'
+               -- Loop
+          iteration us2 (iteration_no + 1) all_counts binds'
        }  } } }
       where
          (us1, us2) = splitUniqSupply us