X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=5b52d2d2d72eb7bd79a741ec732d81f7e554fae2;hb=9bcaaaaa59acff95886ad3675677e58c43106bd2;hp=0a6c40471744c22e4e61a7a3f43bafcf0bdeeeda;hpb=a33ae68ab331a16fbb6e7d6931d1c38bd8f37a85;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 0a6c404..5b52d2d 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -57,10 +57,12 @@ import StrictAnal	( saBinds )
 import CprAnalyse       ( cprAnalyse )
 #endif
 import Vectorise        ( vectorise )
+import Util
 
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import IO		( hPutStr, stderr )
 import Outputable
+import Control.Monad
 import List		( partition, intersperse )
 import Maybes
 \end{code}
@@ -153,13 +155,13 @@ doCorePass CoreCSE		       = {-# SCC "CommonSubExpr" #-} trBinds  cseProgram
 doCorePass CoreLiberateCase	       = {-# SCC "LiberateCase" #-}  liberateCase
 doCorePass CoreDoFloatInwards          = {-# SCC "FloatInwards" #-}  trBinds  floatInwards
 doCorePass (CoreDoFloatOutwards f)     = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
-doCorePass CoreDoStaticArgs	       = {-# SCC "StaticArgs" #-}    trBinds  doStaticArgs
+doCorePass CoreDoStaticArgs	       = {-# SCC "StaticArgs" #-}    trBindsU  doStaticArgs
 doCorePass CoreDoStrictness	       = {-# SCC "Stranal" #-}       trBinds  dmdAnalPgm
 doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU wwTopBinds
 doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
 doCorePass CoreDoSpecConstr	       = {-# SCC "SpecConstr" #-}    trBindsU specConstrProgram
 doCorePass CoreDoGlomBinds	       = trBinds glomBinds
-doCorePass CoreDoVectorisation         = {-# SCC "Vectorise" #-}     vectorise
+doCorePass (CoreDoVectorisation be)    = {-# SCC "Vectorise" #-}     vectorise be
 doCorePass CoreDoPrintCore	       = observe printCore
 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
 doCorePass CoreDoNothing	       = observe (\ _ _ -> return ())
@@ -282,7 +284,8 @@ 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_deps = deps, mg_rules = local_rules })
+	     guts@(ModGuts { mg_binds = binds, mg_deps = deps 
+	     		   , mg_rules = local_rules, mg_rdr_env = rdr_env })
 	     us 
   = do	{ let 	-- Simplify the local rules; boringly, we need to make an in-scope set
 		-- from the local binders, to avoid warnings from Simplify.simplVar
@@ -315,7 +318,8 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 	      imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
 
 	; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
-		(vcat [text "Local rules", pprRules better_rules,
+		(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
+		 vcat [text "Local rules", pprRules better_rules,
 		       text "",
 		       text "Imported rules", pprRuleBase imp_rule_base])
 
@@ -337,12 +341,19 @@ updateBinders local_rules binds
 				-- arising from specialisation pragmas
 \end{code}
 
-
-We must do some gentle simplification on the template (but not the RHS)
-of each rule.  The case that forced me to add this was the fold/build rule,
+Note [Simplifying the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must do some gentle simplification on the lhs (template) of each
+rule.  The case that forced me to add this was the fold/build rule,
 which without simplification looked like:
 	fold k z (build (/\a. g a))  ==>  ...
 This doesn't match unless you do eta reduction on the build argument.
+Similarly for a LHS like
+	augment g (build h) 
+we do not want to get
+	augment (\a. g a) (build h)
+otherwise we don't match when given an argument like
+	augment (\a. h a a) (build h)
 
 \begin{code}
 simplRule env rule@(BuiltinRule {})
@@ -373,11 +384,17 @@ 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
+--	(c) Template Haskell splices
 --
 -- 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
 
+-- It's important that simplExprGently does eta reduction; see
+-- Note [Simplifying the left-hand side of a RULE] above.  The
+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
+-- but only if -O is on.
+
 simplExprGently env expr = do
     expr1 <- simplExpr env (occurAnalyseExpr expr)
     simplExpr env (occurAnalyseExpr expr1)
@@ -478,19 +495,13 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
 	-- 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.  Size = " ++ show (coreBindsSize binds) ++ "\n" )
-	    else 
-		return ();
-#endif
+      =  WARN(debugIsOn && (max_iterations > 2),
+                text ("Simplifier still going after " ++
+				show max_iterations ++
+			    	" iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
 		-- Subtract 1 from iteration_no to get the
 		-- number of iterations we actually completed
-	    return ("Simplifier baled out", iteration_no - 1, counts, binds)
-	}
+	    return ("Simplifier bailed out", iteration_no - 1, counts, binds)
 
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.