X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=acd0830ee5ea9cf809b9cc2367d4215c2bb2d44a;hb=eeaa039982364fb658d4e6824e078c553ba8c748;hp=60d5eb2ae6129acf4a3de7fc01b21d1eaae67e70;hpb=7a327c1297615a9498e7117a0017b09ff2458d53;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 60d5eb2..acd0830 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -19,7 +19,7 @@ module SimplUtils (
 	mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
 	interestingCallContext, interestingArgContext,
 
-	interestingArg, isStrictBndr, mkArgInfo
+	interestingArg, mkArgInfo
     ) where
 
 #include "HsVersions.h"
@@ -28,6 +28,7 @@ import SimplEnv
 import DynFlags
 import StaticFlags
 import CoreSyn
+import PprCore
 import CoreFVs
 import CoreUtils
 import Literal	
@@ -120,11 +121,12 @@ instance Outputable LetRhsFlag where
 
 instance Outputable SimplCont where
   ppr (Stop ty is_rhs _)  	     = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
-  ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
+  ppr (ApplyTo dup arg se cont)      = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) $$ 
+					  nest 2 (pprSimplEnv se)) $$ ppr cont
   ppr (StrictBind b _ _ _ cont)      = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
   ppr (StrictArg f _ _ cont)         = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ 
-				       (nest 4 (ppr alts $$ ppr (seIdSubst se))) $$ ppr cont
+				       (nest 4 (ppr alts $$ pprSimplEnv se)) $$ ppr cont
   ppr (CoerceIt co cont)	     = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
 
 data DupFlag = OkToDup | NoDup
@@ -214,6 +216,14 @@ interestingArg (Var v)	         = hasSomeUnfolding (idUnfolding v)
 interestingArg (Type _)	         = False
 interestingArg (App fn (Type _)) = interestingArg fn
 interestingArg (Note _ a)	 = interestingArg a
+
+-- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
+-- interestingArg expr | isUnLiftedType (exprType expr)
+--        -- Unlifted args are only ever interesting if we know what they are
+--  =                  case expr of
+--                        Lit lit -> True
+--                        _       -> False
+
 interestingArg other	         = True
 	-- Consider 	let x = 3 in f x
 	-- The substitution will contain (x -> ContEx 3), and we want to
@@ -775,7 +785,7 @@ activeRule env
 			-- to work in Template Haskell when simplifying
 			-- splices, so we get simpler code for literal strings
 	SimplPhase n -> Just (isActive n)
-\end{code}	
+\end{code}
 
 
 %************************************************************************
@@ -794,6 +804,14 @@ mkLam bndrs body
   = do	{ dflags <- getDOptsSmpl
 	; mkLam' dflags bndrs body }
   where
+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
+    mkLam' dflags bndrs (Cast body@(Lam _ _) co)
+	-- Note [Casts and lambdas]
+      = do { lam <- mkLam' dflags (bndrs ++ bndrs') body'
+	   ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+      where	
+	(bndrs',body') = collectBinders body
+
     mkLam' dflags bndrs body
       | dopt Opt_DoEtaReduction dflags,
         Just etad_lam <- tryEtaReduce bndrs body
@@ -809,6 +827,21 @@ mkLam bndrs body
       = returnSmpl (mkLams bndrs body)
 \end{code}
 
+Note [Casts and lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider 
+	(\x. (\y. e) `cast` g1) `cast` g2
+There is a danger here that the two lambdas look separated, and the 
+full laziness pass might float an expression to between the two.
+
+So this equation in mkLam' floats the g1 out, thus:
+	(\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)
+where x:tx.
+
+In general, this floats casts outside lambdas, where (I hope) they might meet
+and cancel with some other cast.
+
+
 --	c) floating lets out through big lambdas 
 --		[only if all tyvar lambdas, and only if this lambda
 --		 is the RHS of a let]
@@ -1249,7 +1282,7 @@ match.  For example:
 	  other -> ...(case x of
 			 0#    -> ...
 			 other -> ...) ...
-\end{code}
+\end{verbatim}
 Here the inner case can be eliminated.  This really only shows up in
 eliminating error-checking code.