X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=2f881d5a4a44f42b6f7ebb5cd573c54cd1abac00;hb=d5e97410a9d7309b53a8df78d69172d3b1592ba7;hp=c59de9fcbd5d6364e378732401f6d4b474ce8beb;hpb=aae14ad368aa747386cc46caf80f8181e4259c6e;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index c59de9f..2f881d5 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1014,7 +1014,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)		$
@@ -1152,7 +1152,6 @@ N  Y	Non-top-level and non-recursive,	Bind args of lifted type, or
 Y  Y	Non-top-level, non-recursive,		Bind all args
 		 and strict (demanded)
 	
-
 For example, given
 
 	x = MkC (y div# z)
@@ -1165,13 +1164,44 @@ because the (y div# z) can't float out of the let. But if it was
 a *strict* let, then it would be a good thing to do.  Hence the
 context information.
 
+Note [Float coercions]
+~~~~~~~~~~~~~~~~~~~~~~
+When we find the binding
+	x = e `cast` co
+we'd like to transform it to
+	x' = e
+	x = x `cast` co		-- A trivial binding
+There's a chance that e will be a constructor application or function, or something
+like that, so moving the coerion to the usage site may well cancel the coersions
+and lead to further optimisation.  Example:
+
+     data family T a :: *
+     data instance T Int = T Int
+
+     foo :: Int -> Int -> Int
+     foo m n = ...
+        where
+          x = T m
+          go 0 = 0
+          go n = case x of { T m -> go (n-m) }
+		-- This case should optimise
+
 \begin{code}
 mkAtomicArgsE :: SimplEnv 
-	      -> Bool	-- A strict binding
- 	      -> OutExpr						-- The rhs
+	      -> Bool		-- A strict binding
+ 	      -> OutExpr	-- The rhs
 	      -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+				-- Consumer for the simpler rhs
 	      -> 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 (substExpr env (Var id)) co) }
+
 mkAtomicArgsE env is_strict rhs thing_inside
   | (Var fun, args) <- collectArgs rhs,				-- It's an application
     isDataConWorkId fun || valArgCount args < idArity fun	-- And it's a constructor or PAP
@@ -1190,7 +1220,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)
@@ -1204,6 +1245,13 @@ mkAtomicArgs :: Bool	-- OK to float unlifted args
 			OutExpr)		  -- things that need case-binding,
 						  -- 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
+	; return (binds `snocOL` (id, rhs'), Cast (Var id) co) }
+
 mkAtomicArgs ok_float_unlifted rhs
   | (Var fun, args) <- collectArgs rhs,				-- It's an application
     isDataConWorkId fun || valArgCount args < idArity fun	-- And it's a constructor or PAP