X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=b3e6bf7cf4e4aabdb35f5f2fb2a67adb351ed2c1;hb=55f3a503d72d89d7c57a0b10093dd4bdb0488c42;hp=404a77f90f6eddfda38ab741afb4d93a5acc8956;hpb=b041525cb968351c4b790639820e99a9d232ea0c;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 404a77f..b3e6bf7 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -911,6 +911,14 @@ simplNote env InlineMe e cont
 simplNote env (CoreNote s) e cont
   = simplExpr env e    `thenSmpl` \ e' ->
     rebuild env (Note (CoreNote s) e') cont
+
+simplNote env note@(TickBox {}) e cont
+  = simplExpr env e    `thenSmpl` \ e' ->
+    rebuild env (Note note e') cont
+
+simplNote env note@(BinaryTickBox {}) e cont
+  = simplExpr env e    `thenSmpl` \ e' ->
+    rebuild env (Note note e') cont
 \end{code}
 
 
@@ -1014,7 +1022,7 @@ completeCall env var cont
 		(if dopt Opt_D_dump_inlinings dflags then
 		   pprTrace "Inlining done" (vcat [
 			text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
-			text "Inlined fn: " <+> ppr unfolding,
+			text "Inlined fn: " $$ nest 2 (ppr unfolding),
 			text "Cont:  " <+> ppr call_cont])
 		 else
 			id)		$
@@ -1195,10 +1203,12 @@ mkAtomicArgsE :: SimplEnv
 	      -> SimplM FloatsWithExpr
 
 mkAtomicArgsE env is_strict (Cast rhs co) thing_inside
+  | not (exprIsTrivial rhs)
 	-- Note [Float coersions]
+	-- See also Note [Take care] below
   = do	{ id <- newId FSLIT("a") (exprType rhs)
 	; completeNonRecX env False id id rhs $ \ env ->
-	  thing_inside env (Cast (Var id) co) }
+	  thing_inside env (Cast (substExpr env (Var id)) co) }
 
 mkAtomicArgsE env is_strict rhs thing_inside
   | (Var fun, args) <- collectArgs rhs,				-- It's an application
@@ -1218,7 +1228,18 @@ mkAtomicArgsE env is_strict rhs thing_inside
 	| otherwise
 	= do { arg_id <- newId FSLIT("a") arg_ty
 	     ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
-	       go env (App fun (Var arg_id)) args }
+	       go env (App fun (substExpr env (Var arg_id))) args }
+		-- Note [Take care]:
+		-- If completeNonRecX was to do a postInlineUnconditionally
+		-- (undoing the effect of introducing the let-binding), we'd find arg_id had
+		-- no binding; hence the substExpr.  This happens if we see
+		--	C (D x `cast` g)
+		-- Then we start by making a variable a1, thus
+		--	let a1 = D x `cast` g in C a1
+		-- But then we deal with the rhs of a1, getting
+		--	let a2 = D x, a1 = a1 `cast` g in C a1
+		-- And now the preInlineUnconditionally kicks in, and we substitute for a1
+	
 	where
 	  arg_ty = exprType arg
 	  no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
@@ -1233,6 +1254,7 @@ mkAtomicArgs :: Bool	-- OK to float unlifted args
 						  -- if the strict-binding flag is on
 
 mkAtomicArgs ok_float_unlifted (Cast rhs co)
+  | not (exprIsTrivial rhs)
 	-- Note [Float coersions]
   = do	{ id <- newId FSLIT("a") (exprType rhs)
 	; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs