X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;fp=compiler%2FdeSugar%2FDsUtils.lhs;h=d932ab1fdbad0b310ca0d1816990220116d3e09d;hp=2a6e03452d899b732b463c85ddd0a9304e104b5b;hb=90ce88a0a9b5611416e592a6ff96781ba884975f;hpb=1bca92d715d8b358ee83ff5ee0bc085bec063e59

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 2a6e034..d932ab1 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -8,7 +8,6 @@ Utilities for desugaring
 This module exports some utility functions of no great interest.
 
 \begin{code}
-
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module DsUtils (
 	EquationInfo(..), 
@@ -23,7 +22,7 @@ module DsUtils (
 	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
 	wrapBind, wrapBinds,
 
-	mkErrorAppDs,
+	mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
 
         seqVar,
 
@@ -236,7 +235,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
 -- let var' = viewExpr var in mr
 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
 mkViewMatchResult var' viewExpr var = 
-    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreApp viewExpr (Var var))))
+    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
 
 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 mkEvalMatchResult var ty
@@ -402,6 +401,85 @@ mkErrorAppDs err_id ty msg = do
     return (mkApps (Var err_id) [Type ty, core_msg])
 \end{code}
 
+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
+
+Note [Desugaring seq (1)]  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 #)
+
+Note [Desugaring seq (2)]  cf Trac #2231
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   let chp = case b of { True -> fst x; False -> 0 }
+   in chp `seq` ...chp...
+Here the seq is designed to plug the space leak of retaining (snd x)
+for too long.
+
+If we rely on the ordinary inlining of seq, we'll get
+   let chp = case b of { True -> fst x; False -> 0 }
+   case chp of _ { I# -> ...chp... }
+
+But since chp is cheap, and the case is an alluring contet, we'll
+inline chp into the case scrutinee.  Now there is only one use of chp,
+so we'll inline a second copy.  Alas, we've now ruined the purpose of
+the seq, by re-introducing the space leak:
+    case (case b of {True -> fst x; False -> 0}) of
+      I# _ -> ...case b of {True -> fst x; False -> 0}...
+
+We can try to avoid doing this by ensuring that the binder-swap in the
+case happens, so we get his at an early stage:
+   case chp of chp2 { I# -> ...chp2... }
+But this is fragile.  The real culprit is the source program.  Perhaps we
+should have said explicitly
+   let !chp2 = chp in ...chp2...
+
+But that's painful.  So the code here does a little hack to make seq
+more robust: a saturated application of 'seq' is turned *directly* into
+the case expression. So we desugar to:
+   let chp = case b of { True -> fst x; False -> 0 }
+   case chp of chp { I# -> ...chp... }
+Notice the shadowing of the case binder! And now all is well.
+
+The reason it's a hack is because if you define mySeq=seq, the hack
+won't work on mySeq.  
+
+Note [Desugaring seq (3)] cf Trac #2409
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The isLocalId ensures that we don't turn 
+        True `seq` e
+into
+        case True of True { ... }
+which stupidly tries to bind the datacon 'True'. 
+
+\begin{code}
+mkCoreAppDs  :: CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
+  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
+  where
+    case_bndr = case arg1 of
+                   Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
+                   _                     -> mkWildBinder ty1
+
+mkCoreAppDs fun arg = mkCoreApp fun arg	 -- The rest is done in MkCore
+
+mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection[mkSelectorBind]{Make a selector bind}