X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=588f71d57e24d52b96262950e8af79bdae8ed7a2;hb=b2d633b6251dec6704cfeccbd8638716cf5202f0;hp=79ebf09a5501ba5617093ff35a93171ac3b3664d;hpb=a7b95beb6077ff7c330e98c3d5b9268f33b21827;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 79ebf09..588f71d 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -248,8 +248,15 @@ simplTopBinds env binds
     drop_bs (NonRec _ _) (_ : bs) = bs
     drop_bs (Rec prs)    bs	  = drop (length prs) bs
 
-    simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
-    simpl_bind env (Rec pairs)  bs'    = simplRecBind      env TopLevel pairs bs'
+    simpl_bind env bind bs 
+      = getDOptsSmpl				`thenSmpl` \ dflags ->
+        if dopt Opt_D_dump_inlinings dflags then
+	   pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs
+	else
+	   simpl_bind1 env bind bs
+
+    simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+    simpl_bind1 env (Rec pairs)  bs'    = simplRecBind      env TopLevel pairs bs'
 \end{code}
 
 
@@ -500,10 +507,10 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
 		-- There's a subtlety here.  There may be a binding (x* = e) in the
 		-- floats, where the '*' means 'will be demanded'.  So is it safe
 		-- to float it out?  Answer no, but it won't matter because
-		-- we only float if arg' is a WHNF,
+		-- we only float if (a) arg' is a WHNF, or (b) it's going to top level
 		-- and so there can't be any 'will be demanded' bindings in the floats.
-		-- Hence the assert
-        WARN( any demanded_float (floatBinds floats), 
+		-- Hence the warning
+        WARN( not is_top_level && any demanded_float (floatBinds floats), 
 	      ppr (filter demanded_float (floatBinds floats)) )
 
 	tick LetFloatFromLet			`thenSmpl_` (
@@ -788,12 +795,14 @@ simplNote env (Coerce to from) body cont
 						-- the inner one is redundant
 
 	addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
-	  | Just (s1, s2) <- splitFunTy_maybe s1s2
+	  | not (isTypeArg arg),	-- This whole case only works for value args
+					-- Could upgrade to have equiv thing for type apps too	
+ 	    Just (s1, s2) <- splitFunTy_maybe s1s2
 		--	(coerce (T1->T2) (S1->S2) F) E
 		-- ===> 
 		--	coerce T2 S2 (F (coerce S1 T1 E))
 		--
-		-- t1t2 must be a function type, T1->T2
+		-- t1t2 must be a function type, T1->T2, because it's applied to something
 		-- but s1s2 might conceivably not be
 		--
 		-- When we build the ApplyTo we can't mix the out-types
@@ -909,7 +918,7 @@ completeCall env var occ_info cont
 		tick (RuleFired rule_name)			`thenSmpl_`
 		(if dopt Opt_D_dump_inlinings dflags then
 		   pprTrace "Rule fired" (vcat [
-			text "Rule:" <+> ptext rule_name,
+			text "Rule:" <+> ftext rule_name,
 			text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
 			text "After: " <+> pprCoreExpr rule_rhs,
 			text "Cont:  " <+> ppr call_cont])
@@ -1038,11 +1047,14 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
   | is_strict 
   = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
 
-  | otherwise
-  = simplExprF (setInScope arg_se env) val_arg
-	       (mkStop arg_ty AnArg)		`thenSmpl` \ (floats, arg1) ->
-    addFloats env floats			$ \ env ->
-    thing_inside env arg1
+  | otherwise	-- Lazy argument
+		-- DO NOT float anything outside, hence simplExprC
+		-- There is no benefit (unlike in a let-binding), and we'd
+		-- have to be very careful about bogus strictness through 
+		-- floating a demanded let.
+  = simplExprC (setInScope arg_se env) val_arg
+	       (mkStop arg_ty AnArg)		`thenSmpl` \ arg1 ->
+   thing_inside env arg1
   where
     arg_ty = funArgTy fn_ty
 
@@ -1233,7 +1245,7 @@ rebuildCase env scrut case_bndr alts cont
 
   | otherwise
   = prepareAlts scrut case_bndr alts		`thenSmpl` \ (better_alts, handled_cons) -> 
-
+	
 	-- Deal with the case binder, and prepare the continuation;
 	-- The new subst_env is in place
     prepareCaseCont env better_alts cont	`thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
@@ -1680,7 +1692,7 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
     )							`thenSmpl` \ (final_bndrs', final_args) ->
 
 	-- See comment about "$j" name above
-    newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty')	`thenSmpl` \ join_bndr ->
+    newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty')	`thenSmpl` \ join_bndr ->
 	-- Notice the funky mkPiTypes.  If the contructor has existentials
 	-- it's possible that the join point will be abstracted over
 	-- type varaibles as well as term variables.