Improve strictness analysis for exceptions

Two things here:

* For exceptions-catching primops like catch#, we know
  that the main argument function will be called, so
  we can use strictApply1Dmd, rather than lazy

  Changes in primops.txt.pp

* When a 'case' scrutinises a I/O-performing primop,
  the Note [IO hack in the demand analyser] was
  throwing away all strictness from the code that
  followed.

  I found that this was causing quite a bit of unnecessary
  reboxing in the (heavily used) function
  GHC.IO.Handle.Internals.wantReadableHandle

  So this patch prevents the hack applying when the
  case scrutinises a primop.  See the revised
  Note [IO hack in the demand analyser]

Thse two things buy us quite a lot in programs that do a lot of IO.

        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
            hpg          -0.4%     -2.9%     -0.9%     -1.0%     +0.0%
reverse-complem          -0.4%    -10.9%    +10.7%    +10.9%     +0.0%
         simple          -0.3%     -0.0%    +26.2%    +26.2%     +3.7%
         sphere          -0.3%     -6.3%      0.09      0.09     +0.0%
--------------------------------------------------------------------------------
            Min          -0.7%    -10.9%     -4.6%     -4.7%     -1.7%
            Max          -0.2%     +0.0%    +26.2%    +26.2%     +6.5%
 Geometric Mean          -0.4%     -0.3%     +2.1%     +2.1%     +0.1%

I think the increase in runtime for 'simple' is measurement error.

1 files changed, 53 insertions, 26 deletions

diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 79dd492ce7..41d9abb921 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -220,8 +220,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
         (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
         id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
-        alt_ty3 | io_hack_reqd dc bndrs = deferAfterIO alt_ty2
-                | otherwise             = alt_ty2
+        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
+                | otherwise                   = alt_ty2
 
         -- Compute demand on the scrutinee
         -- See Note [Demand on scrutinee of a product case]
@@ -292,29 +292,16 @@ dmdAnal' env dmd (Let (Rec pairs) body)
     body_ty2 `seq`
     (body_ty2,  Let (Rec pairs') body')
 
-io_hack_reqd :: DataCon -> [Var] -> Bool
--- Note [IO hack in the demand analyser]
---
--- 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 (Trac #148, #1592) where this shows up is:
---      do { let len = <expensive> ;
---         ; when (...) (exitWith ExitSuccess)
---         ; print len }
-io_hack_reqd con bndrs
+io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
+-- See Note [IO hack in the demand analyser]
+io_hack_reqd scrut con bndrs
   | (bndr:_) <- bndrs
-  = con == unboxedPairDataCon &&
-    idType bndr `eqType` realWorldStatePrimTy
+  , con == unboxedPairDataCon
+  , idType bndr `eqType` realWorldStatePrimTy
+  , (fun, _) <- collectArgs scrut
+  = case fun of
+      Var f -> not (isPrimOpId f)
+      _     -> True
   | otherwise
   = False
 
@@ -350,8 +337,48 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
         id_dmds       = addCaseBndrDmd case_bndr_dmd dmds
   = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
 
-{- Note [Demand on the scrutinee of a product case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+{- Note [IO hack in the demand analyser]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 (Trac #148, #1592) where this shows up is:
+     do { let len = <expensive> ;
+        ; when (...) (exitWith ExitSuccess)
+        ; print len }
+
+However, consider
+  f x s = case getMaskingState# s of
+            (# s, r #) ->
+          case x of I# x2 -> ...
+
+Here it is terribly sad to make 'f' lazy in 's'.  After all,
+getMaskingState# is not going to diverge or throw an exception!  This
+situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
+(on an MVar not an Int), and make a material difference.
+
+So if the scrutinee is a primop call, we *don't* apply the
+state hack:
+  - If is a simple, terminating one like getMaskingState,
+    applying the hack is over-conservative.
+  - If the primop is raise# then it returns bottom, so
+    the case alternatives are alraedy discarded.
+  - If the primop can raise a non-IO exception, like
+    divide by zero or seg-fault (eg writing an array
+    out of bounds) then we don't mind evaluating 'x' first.
+
+Note [Demand on the scrutinee of a product case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When figuring out the demand on the scrutinee of a product case,
 we use the demands of the case alternative, i.e. id_dmds.
 But note that these include the demand on the case binder;