Improve the treatment of 'seq' (Trac #2273)

[ghc-hetmet.git] / compiler / deSugar / DsUtils.lhs

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index cf670cd..4334a12 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -117,7 +117,7 @@ lookupEvidence :: [(Name, Id)] -> Name -> Id
 lookupEvidence prs std_name
   = assocDefault (mk_panic std_name) prs std_name
   where
-    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
+    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
 \end{code}
 
 
@@ -163,14 +163,18 @@ mkDsApps fun args
                                     (arg_ty, res_ty) = splitFunTy fun_ty
 -----------
 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
+mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
+  | f == seqId         -- Note [Desugaring seq (1), (2)]
+  = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
+  where
+    case_bndr = case arg1 of
+                  Var v1 -> v1 -- Note [Desugaring seq (2)]
+                  _      -> mkWildId ty1
+
 mk_val_app fun arg arg_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 _ `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
   = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
   where
@@ -178,8 +182,8 @@ mk_val_app fun arg arg_ty res_ty
                                -- because 'fun ' should not have a free wild-id
 \end{code}
 
-Note [Desugaring seq]  cf Trac #1031
-~~~~~~~~~~~~~~~~~~~~~
+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 
@@ -194,10 +198,41 @@ But that is bad for two reasons:
 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.
-
+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.  Perhpas 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.  
 
 %************************************************************************
 %*                                                                     *
@@ -872,7 +907,7 @@ mkTupleCase uniqs vars body scrut_var scrut
     
     one_tuple_case chunk_vars (us, vs, body)
       = let (us1, us2) = splitUniqSupply us
-            scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
+            scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
               (mkCoreTupTy (map idType chunk_vars))
             body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
         in (us2, scrut_var:vs, body')
@@ -1059,7 +1094,7 @@ mkTickBox ix vars e = do
 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 mkBinaryTickBox ixT ixF e = do
        uq <- newUnique         
-       let bndr1 = mkSysLocal FSLIT("t1") uq boolTy 
+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy 
        falseBox <- mkTickBox ixF [] $ Var falseDataConId
        trueBox  <- mkTickBox ixT [] $ Var trueDataConId
        return $ Case e bndr1 boolTy