X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=beb1ed0e7cfb74c8b75d28cd5b28611c9c2a611f;hp=0f881cf07bbc5ff890992a4fbd01e73dcf640800;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hpb=931d450e1f3c601e35f6e2460f721152bd458976

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 0f881cf..beb1ed0 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -31,6 +31,7 @@ import OccurAnal	( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
 import CoreUtils	( coreBindsSize )
 import Simplify		( simplTopBinds, simplExpr )
+import SimplUtils	( simplEnvForGHCi, simplEnvForRules )
 import SimplEnv
 import SimplMonad
 import CoreMonad
@@ -54,10 +55,6 @@ import Specialise	( specProgram)
 import SpecConstr	( specConstrProgram)
 import DmdAnal		( dmdAnalPgm )
 import WorkWrap	        ( wwTopBinds )
-#ifdef OLD_STRICTNESS
-import StrictAnal	( saBinds )
-import CprAnalyse       ( cprAnalyse )
-#endif
 import Vectorise        ( vectorise )
 import FastString
 import Util
@@ -120,6 +117,8 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 	     -> IO CoreExpr
 -- simplifyExpr is called by the driver to simplify an
 -- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
 simplifyExpr dflags expr
   = do	{
 	; Err.showPass dflags "Simplify"
@@ -127,7 +126,7 @@ simplifyExpr dflags expr
 	; us <-  mkSplitUniqSupply 's'
 
 	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-				 simplExprGently gentleSimplEnv expr
+				 simplExprGently simplEnvForGHCi expr
 
 	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
 			(pprCoreExpr expr')
@@ -135,9 +134,6 @@ simplifyExpr dflags expr
 	; return expr'
 	}
 
-gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently  (isAmongSimpl [])
-
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
 doCorePasses passes guts = foldM (flip doCorePass) guts passes
 
@@ -190,24 +186,8 @@ doCorePass CoreDoGlomBinds              = dontDescribePass $ doPassDM  glomBinds
 doCorePass CoreDoPrintCore              = dontDescribePass $ observe   printCore
 doCorePass (CoreDoRuleCheck phase pat)  = dontDescribePass $ ruleCheck phase pat
 
-#ifdef OLD_STRICTNESS
-doCorePass CoreDoOldStrictness          = {-# SCC "OldStrictness" #-} doOldStrictness
-#endif
-
 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes
-
-#ifdef OLD_STRICTNESS
-doOldStrictness :: ModGuts -> CoreM ModGuts
-doOldStrictness guts
-  = do dfs <- getDynFlags
-       guts'  <- describePass "Strictness analysis" Opt_D_dump_stranal $ 
-                 doPassM (saBinds dfs) guts
-       guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $ 
-                 doPass cprAnalyse guts'
-       return guts''
-#endif
-
 \end{code}
 
 %************************************************************************
@@ -333,7 +313,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 	; 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 gentleSimplEnv local_ids 
+	      env	       = setInScopeSet simplEnvForRules local_ids 
 	      (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
 				 mapM (simplRule env) local_rules
 
@@ -409,6 +389,7 @@ The simplifier does indeed do eta reduction (it's in
 Simplify.completeLam) but only if -O is on.
 
 \begin{code}
+simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
 simplRule env rule@(BuiltinRule {})
   = return rule
 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
@@ -571,7 +552,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
 	   eps <- hscEPS hsc_env ;
 	   let	{ rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
 	        ; rule_base2 = extendRuleBaseList rule_base1 rules
-		; simpl_env  = mkSimplEnv mode sw_chkr 
+		; 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) } ;
@@ -843,7 +824,7 @@ transferIdInfo exported_id local_id
   = modifyIdInfo transfer exported_id
   where
     local_info = idInfo local_id
-    transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
+    transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
 				 `setUnfoldingInfo`     unfoldingInfo local_info
 				 `setInlinePragInfo`	inlinePragInfo local_info
 				 `setSpecInfo`	        addSpecInfo (specInfo exp_info) new_info