X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=d4a050499f45fddce5f38a92e1cc8662a4336583;hb=7f7b6cefcfbcf81ca3abd18c65498c5ba4860204;hp=62f226c8ad8a268557fc8d6c3ff7475aa3789acf;hpb=8100cd4395e46ae747be4298c181a4730d6206bc;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 62f226c..d4a0504 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -8,9 +8,7 @@ module Simplify ( simplTopBinds, simplExpr ) where
 
 #include "HsVersions.h"
 
-import DynFlags	( dopt, DynFlag(Opt_D_dump_inlinings),
-			  SimplifierSwitch(..)
-			)
+import DynFlags
 import SimplMonad
 import Type hiding	( substTy, extendTvSubst )
 import SimplEnv	
@@ -208,7 +206,8 @@ simplTopBinds env binds
 		-- It's rather as if the top-level binders were imported.
 	; env <- simplRecBndrs env (bindersOfBinds binds)
 	; dflags <- getDOptsSmpl
-	; let dump_flag = dopt Opt_D_dump_inlinings dflags
+	; let dump_flag = dopt Opt_D_dump_inlinings dflags || 
+			  dopt Opt_D_dump_rule_firings dflags
 	; env' <- simpl_binds dump_flag env binds
 	; freeTick SimplifierDone
 	; return (getFloats env') }
@@ -216,6 +215,9 @@ simplTopBinds env binds
 	-- We need to track the zapped top-level binders, because
 	-- they should have their fragile IdInfo zapped (notably occurrence info)
 	-- That's why we run down binds and bndrs' simultaneously.
+	--
+	-- The dump-flag emits a trace for each top-level binding, which
+	-- helps to locate the tracing for inlining and rule firing
     simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
     simpl_binds dump env []	      = return env
     simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $
@@ -357,7 +359,7 @@ simplNonRecX :: SimplEnv
 simplNonRecX env bndr new_rhs
   = do	{ (env, bndr') <- simplBinder env bndr
 	; completeNonRecX env NotTopLevel NonRecursive
-			  (isStrictBndr bndr) bndr bndr' new_rhs }
+			  (isStrictId bndr) bndr bndr' new_rhs }
 
 completeNonRecX :: SimplEnv
 		-> TopLevelFlag -> RecFlag -> Bool
@@ -410,7 +412,7 @@ becomes
 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Adds new floats to the env iff that allows us to return a good RHS
 
-prepareRhs env (Cast rhs co)	-- Note [Float coersions]
+prepareRhs env (Cast rhs co)	-- Note [Float coercions]
   = do	{ (env', rhs') <- makeTrivial env rhs
 	; return (env', Cast rhs' co) }
 
@@ -630,12 +632,12 @@ simplExprF env e cont
   = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
     simplExprF' env e cont
     				     
-simplExprF' env (Var v)	      cont = simplVar env v cont
+simplExprF' env (Var v)	       cont = simplVar env v cont
 simplExprF' env (Lit lit)      cont = rebuild env (Lit lit) cont
 simplExprF' env (Note n expr)  cont = simplNote env n expr cont
 simplExprF' env (Cast body co) cont = simplCast env body co cont
 simplExprF' env (App fun arg)  cont = simplExprF env fun $
-				     ApplyTo NoDup arg env cont
+				      ApplyTo NoDup arg env cont
 
 simplExprF' env expr@(Lam _ _) cont 
   = simplLam env (map zap bndrs) body cont
@@ -733,12 +735,13 @@ simplCast env body co cont
   = do	{ co' <- simplType env co
 	; simplExprF env body (addCoerce co' cont) }
   where
-       addCoerce co cont 
-         | (s1, k1) <- coercionKind co
-         , s1 `coreEqType` k1 = cont
-       addCoerce co1 (CoerceIt co2 cont)
-         | (s1, k1) <- coercionKind co1
-         , (l1, t1) <- coercionKind co2
+       addCoerce co cont = add_coerce co (coercionKind co) cont
+
+       add_coerce co (s1, k1) cont 	-- co :: ty~ty
+         | s1 `coreEqType` k1 = cont	-- is a no-op
+
+       add_coerce co1 (s1, k2) (CoerceIt co2 cont)
+         | (l1, t1) <- coercionKind co2
                 -- 	coerce T1 S1 (coerce S1 K1 e)
 		-- ==>
 		--	e, 			if T1=K1
@@ -751,11 +754,10 @@ simplCast env body co cont
          , s1 `coreEqType` t1  = cont		 -- The coerces cancel out  
          | otherwise           = CoerceIt (mkTransCoercion co1 co2) cont
     
-       addCoerce co (ApplyTo dup arg arg_se cont)
-         | not (isTypeArg arg)    -- This whole case only works for value args
+       add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
+         | not (isTypeArg arg)  -- This whole case only works for value args
 	                        -- Could upgrade to have equiv thing for type apps too	
-         , Just (s1s2, t1t2) <- splitCoercionKind_maybe co
-         , isFunTy s1s2
+         , isFunTy s1s2	  -- t1t2 must be a function type, becuase it's applied
                 -- co : s1s2 :=: t1t2
 		--	(coerce (T1->T2) (S1->S2) F) E
 		-- ===> 
@@ -768,6 +770,8 @@ simplCast env body co cont
 		-- with the InExpr in the argument, so we simply substitute
 		-- to make it all consistent.  It's a bit messy.
 		-- But it isn't a common case.
+		--
+		-- Example of use: Trac #995
          = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
          where
            -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and 
@@ -777,7 +781,7 @@ simplCast env body co cont
            new_arg    = mkCoerce (mkSymCoercion co1) arg'
 	   arg'       = substExpr arg_se arg
 
-       addCoerce co cont = CoerceIt co cont
+       add_coerce co _ cont = CoerceIt co cont
 \end{code}
 
 
@@ -838,7 +842,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
   = do	{ tick (PreInlineUnconditionally bndr)
 	; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
 
-  | isStrictBndr bndr
+  | isStrictId bndr
   = do	{ simplExprF (rhs_se `setFloats` env) rhs 
 		     (StrictBind bndr bndrs body env cont) }
 
@@ -944,7 +948,7 @@ completeCall env var cont
 	; case maybe_rule of {
 	    Just (rule, rule_rhs) -> 
 		tick (RuleFired (ru_name rule))			`thenSmpl_`
-		(if dopt Opt_D_dump_inlinings dflags then
+		(if dopt Opt_D_dump_rule_firings dflags then
 		   pprTrace "Rule fired" (vcat [
 			text "Rule:" <+> ftext (ru_name rule),
 			text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
@@ -1122,18 +1126,10 @@ in action in spectral/cichelli/Prog.hs:
 	 [(m,n) | m <- [1..max], n <- [1..max]]
 Hence the check for NoCaseOfCase.
 
-Note [Case of cast]
-~~~~~~~~~~~~~~~~~~~
-Consider 	case (v `cast` co) of x { I# ->
-		... (case (v `cast` co) of {...}) ...
-We'd like to eliminate the inner case.  We can get this neatly by 
-arranging that inside the outer case we add the unfolding
-	v |-> x `cast` (sym co)
-to v.  Then we should inline v at the inner case, cancel the casts, and away we go
-	
-Note 2
-~~~~~~
-There is another situation when we don't want to do it.  If we have
+Note [Suppressing the case binder-swap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is another situation when it might make sense to suppress the
+case-expression binde-swap. If we have
 
     case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
 	           ...other cases .... }
@@ -1195,6 +1191,15 @@ The point is that we bring into the envt a binding
 after the outer case, and that makes (a,b) alive.  At least we do unless
 the case binder is guaranteed dead.
 
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider 	case (v `cast` co) of x { I# ->
+		... (case (v `cast` co) of {...}) ...
+We'd like to eliminate the inner case.  We can get this neatly by 
+arranging that inside the outer case we add the unfolding
+	v |-> x `cast` (sym co)
+to v.  Then we should inline v at the inner case, cancel the casts, and away we go
+	
 \begin{code}
 simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
 simplCaseBinder env scrut case_bndr