From 3bdbcf162f78f28d3d50d30456aced559473b878 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 16 Mar 2007 15:17:12 +0000
Subject: [PATCH] Desugar applications of 'seq' specially; fix Trac #1031

Merge to 6.6 branch.  Test case is dsrun014.

Note [Desugaring seq]  cf Trac #1031
~~~~~~~~~~~~~~~~~~~~~
   f x y = x `seq` (y `seq` (# x,y #))

The [CoreSyn let/app invariant] means that, other things being equal, because
the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:

   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v

But that is bad for two reasons:
  (a) we now evaluate y before x, and
  (b) we can't bind v to an unboxed pair

Seq is very, very special!  So we recognise it right here, and desugar to
	case x of _ -> case y of _ -> (# x,y #)

The special case would be valid for all calls to 'seq', but it's only *necessary*
for ones whose second argument has an unlifted type. So we only catch the latter
case here, to avoid unnecessary tests.
---
 compiler/deSugar/DsUtils.lhs |   40 ++++++++++++++++++++++++++++++----------
 1 file changed, 30 insertions(+), 10 deletions(-)

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 71a8320..455db04 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -70,11 +70,6 @@ import Util
 import ListSetOps
 import FastString
 import Data.Char
-import DynFlags
-
-#ifdef DEBUG
-import Util
-#endif
 
 infixl 4 `mkDsApp`, `mkDsApps`
 \end{code}
@@ -123,7 +118,7 @@ back again.
 
 \begin{code}
 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
-mkDsLet (NonRec bndr rhs) body
+mkDsLet (NonRec bndr rhs) body	-- See Note [CoreSyn let/app invariant]
   | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
   = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 mkDsLet bind body
@@ -153,16 +148,41 @@ mkDsApps fun args
 				   where
 				     (arg_ty, res_ty) = splitFunTy fun_ty
 -----------
+mk_val_app fun arg arg_ty res_ty	-- See Note [CoreSyn let/app invariant]
+  | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
+  = App fun arg		-- The vastly common case
+
+mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty
+  | f == seqId		-- Note [Desugaring seq]
+  = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)]
+
 mk_val_app fun arg arg_ty res_ty
-  | isUnLiftedType arg_ty && not (exprOkForSpeculation arg)
-  = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
-  | otherwise		-- The common case
-  = App fun arg
+  = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
   where
     arg_id = mkWildId arg_ty	-- Lots of shadowing, but it doesn't matter,
 				-- because 'fun ' should not have a free wild-id
 \end{code}
 
+Note [Desugaring seq]  cf Trac #1031
+~~~~~~~~~~~~~~~~~~~~~
+   f x y = x `seq` (y `seq` (# x,y #))
+
+The [CoreSyn let/app invariant] means that, other things being equal, because 
+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
+
+   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
+
+But that is bad for two reasons: 
+  (a) we now evaluate y before x, and 
+  (b) we can't bind v to an unboxed pair
+
+Seq is very, very special!  So we recognise it right here, and desugar to
+	case x of _ -> case y of _ -> (# x,y #)
+
+The special case would be valid for all calls to 'seq', but it's only *necessary*
+for ones whose second argument has an unlifted type. So we only catch the latter
+case here, to avoid unnecessary tests.
+
 
 %************************************************************************
 %*									*
-- 
1.7.10.4