[project @ 2003-06-23 11:46:40 by simonpj]

------------------------------------------------------
	Make the strictness analyser more conservative for I/O
	------------------------------------------------------

Consider
	do { let len = <expensive> ;
	   ; when (...) (exitWith ExitSuccess)
	   ; print len }

Is it safe to evaluate <expensive> before doing the 'when'?  Remember,
<expensive> might raise an exception etc as well.

Normal strictness analysis answer: yes, because either the when... diverges
or raises an exception, or the print will happen.

Correct I/O answer: no, because it's perfectly OK to terminate the program
successfully.  And don't say the 'len' could be pushed down, because (a) sometimes
it can't and (b) sometimes the compiler might float it out.

This commit adds a hack to the demand analyser, so that it treats a case that
looks like I/O (unboxed pair, real-world as first bindre) specially, by lub'ing
the returned strictness type with TopType.  A bit like adding a dummy never-taken
branch.  This seems a bit hack-oid, but it's quick and it works.  Not clear
how to do it 'right', either.

Test is in stranal/should_run/strun003.

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index b6bd92f..b27a30e 100644 (file)
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -35,9 +35,11 @@ import IdInfo                ( newStrictnessFromOld, newDemand )
 #endif
 import Var             ( Var )
 import VarEnv
+import TysWiredIn      ( unboxedPairDataCon )
+import TysPrim         ( realWorldStatePrimTy )
 import UniqFM          ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
                          keysUFM, minusUFM, ufmToList, filterUFM )
-import Type            ( isUnLiftedType )
+import Type            ( isUnLiftedType, eqType )
 import CoreLint                ( showPass, endPass )
 import Util            ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
 import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
@@ -306,8 +308,30 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs)
   = let 
        (rhs_ty, rhs')   = dmdAnal sigs dmd rhs
        (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs
-    in
-    (alt_ty, (con, bndrs', rhs'))
+       final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType
+                    | otherwise    = alt_ty
+
+       -- There's a hack here for I/O operations.  Consider
+       --      case foo x s of { (# s, r #) -> y }
+       -- Is this strict in 'y'.  Normally yes, but what if 'foo' is an I/O
+       -- operation that simply terminates the program (not in an erroneous way)?
+       -- In that case we should not evaluate y before the call to 'foo'.
+       -- Hackish solution: spot the IO-like situation and add a virtual branch,
+       -- as if we had
+       --      case foo x s of 
+       --         (# s, r #) -> y 
+       --         other      -> return ()
+       -- So the 'y' isn't necessarily going to be evaluated
+       --
+       -- A more complete example where this shows up is:
+       --      do { let len = <expensive> ;
+       --         ; when (...) (exitWith ExitSuccess)
+       --         ; print len }
+
+       io_hack_reqd = con == DataAlt unboxedPairDataCon &&
+                      idType (head bndrs) `eqType` realWorldStatePrimTy
+    in 
+    (final_alt_ty, (con, bndrs', rhs'))
 \end{code}
 
 %************************************************************************