[project @ 2005-02-25 12:50:48 by simonpj]

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

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index ba34b0c..32c6978 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -15,16 +15,17 @@ import CmdLineOpts  ( CoreToDo(..), SimplifierSwitch(..),
 import CoreSyn
 import TcIface         ( loadImportedRules )
 import HscTypes                ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
-                         ModDetails(..), HomeModInfo(..), hscEPS )
+                         ModDetails(..), HomeModInfo(..), HomePackageTable, Dependencies( dep_mods ), 
+                         hscEPS, hptRules )
 import CSE             ( cseProgram )
 import Rules           ( RuleBase, ruleBaseIds, emptyRuleBase,
                          extendRuleBaseList, pprRuleBase, ruleCheckProgram )
-import Module          ( moduleEnvElts )
+import Module          ( elemModuleEnv, lookupModuleEnv )
 import PprCore         ( pprCoreBindings, pprCoreExpr, pprIdRules )
 import OccurAnal       ( occurAnalyseBinds, occurAnalyseGlobalExpr )
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
-import SimplUtils      ( simplBinders )
+import SimplEnv                ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
 import SimplMonad
 import ErrUtils                ( dumpIfSet, dumpIfSet_dyn, showPass )
 import CoreLint                ( endPass )
@@ -48,7 +49,7 @@ import UniqSupply     ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import IO              ( hPutStr, stderr )
 import Outputable
 import List            ( partition )
-import Maybes          ( orElse )
+import Maybes          ( orElse, fromJust )
 \end{code}
 
 %************************************************************************
@@ -98,8 +99,8 @@ simplifyExpr dflags expr
 
        ; us <-  mkSplitUniqSupply 's'
 
-       ; let env              = emptySimplEnv SimplGently []
-             (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
+       ; let (expr', _counts) = initSmpl dflags us $
+                                simplExprGently gentleSimplEnv expr
 
        ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                        (pprCoreExpr expr')
@@ -107,6 +108,11 @@ simplifyExpr dflags expr
        ; return expr'
        }
 
+gentleSimplEnv :: SimplEnv
+gentleSimplEnv = mkSimplEnv SimplGently 
+                           (isAmongSimpl [])
+                           emptyRuleBase
+
 doCorePasses :: HscEnv
              -> UniqSupply      -- uniques
             -> SimplCount      -- simplifier stats
@@ -209,15 +215,16 @@ prepareRules :: HscEnv
                                        --      (b) Rules are now just orphan rules
 
 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
-            guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
+            guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
             us 
   = do { eps <- hscEPS hsc_env
 
        ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
                -- from the local binders, to avoid warnings from Simplify.simplVar
              local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
-             env              = setInScopeSet (emptySimplEnv SimplGently []) local_ids 
+             env              = setInScopeSet gentleSimplEnv local_ids 
              (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
+             home_pkg_rules   = hptRules hsc_env (dep_mods deps)
 
              (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
                -- Get the rules for locally-defined Ids out of the RuleBase
@@ -234,7 +241,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
                --     rules for Ids in this module; if there is, the above bad things may happen
 
              pkg_rule_base = eps_rule_base eps
-             hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+             hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules
              imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
 
                -- Update the binders in the local bindings with the lcoal rules
@@ -262,14 +269,12 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
                       text "Imported rules", pprRuleBase imp_rule_base])
 
 #ifdef DEBUG
-       ; let bad_rules = filter (idIsFrom (mg_mod guts)) 
+       ; let bad_rules = filter (idIsFrom (mg_module guts)) 
                                 (varSetElems (ruleBaseIds imp_rule_base))
        ; WARN( not (null bad_rules), ppr bad_rules ) return ()
 #endif
        ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
     }
-  where
-    add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
 
 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
 updateBinders rule_base binds
@@ -413,8 +418,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
                          SimplGently  -> "gentle"
                          SimplPhase n -> show n
 
-    simpl_env        = emptySimplEnv mode switches
-    sw_chkr          = getSwitchChecker simpl_env
+    sw_chkr          = isAmongSimpl switches
     max_iterations    = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
  
     do_iteration us rule_base iteration_no counts guts
@@ -455,8 +459,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
                -- miss the rules for Ids hidden inside imported inlinings
           new_rules <- loadImportedRules hsc_env guts ;
           let  { rule_base' = extendRuleBaseList rule_base new_rules
-               ; in_scope   = mkInScopeSet (ruleBaseIds rule_base')
-               ; simpl_env' = setInScopeSet simpl_env in_scope } ;
+               ; simpl_env  = mkSimplEnv mode sw_chkr rule_base' } ;
                        -- The new rule base Ids are used to initialise
                        -- the in-scope set.  That way, the simplifier will change any
                        -- occurrences of the imported id to the one in the imported_rule_ids
@@ -473,7 +476,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
                --      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 {
+          case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
                (binds', counts') -> do {
 
           let  { guts'      = guts { mg_binds = binds' }