X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=32c6978cecfe7f1ba18a814432ef40118c810b63;hb=d9fd6a665237f0e2ab769915db873b9d72bd1c0a;hp=ba34b0c0af9115a6669ab807c7a1e40e399e320e;hpb=1f7da30204a9b735e8bc543a5bacf03135bcc9c7;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index ba34b0c..32c6978 100644
--- 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' }