Make demand analysis understand catch

As Trac #11222, and #10712 note, the strictness analyser
needs to be rather careful about exceptions.  Previously
it treated them as identical to divergence, but that
won't quite do.

See Note [Exceptions and strictness] in Demand, which
explains the deal.

Getting more strictness in 'catch' and friends is a
very good thing.  Here is the nofib summary, keeping
only the big ones.

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
          fasta          -0.1%     -6.9%     -3.0%     -3.0%     +0.0%
            hpg          -0.1%     -2.0%     -6.2%     -6.2%     +0.0%
       maillist          -0.1%     -0.3%      0.08      0.09     +1.2%
reverse-complem          -0.1%    -10.9%     -6.0%     -5.9%     +0.0%
         sphere          -0.1%     -4.3%      0.08      0.08     +0.0%
           x2n1          -0.1%     -0.0%      0.00      0.00     +0.0%
--------------------------------------------------------------------------------
            Min          -0.2%    -10.9%    -17.4%    -17.3%     +0.0%
            Max          -0.0%     +0.0%     +4.3%     +4.4%     +1.2%
 Geometric Mean          -0.1%     -0.3%     -2.9%     -3.0%     +0.0%

On the way I did quite a bit of refactoring in Demand.hs

compiler/coreSyn/CoreArity.hs

@@ -140,8 +140,9 @@ exprBotStrictness_maybe e
         Just ar -> Just (ar, sig ar)
   where
     env    = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
-    sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
+    sig ar = mkClosedStrictSig (replicate ar topDmd) exnRes
                   -- For this purpose we can be very simple
+                  -- exnRes is a bit less aggressive than botRes
 
 {-
 Note [exprArity invariant]

compiler/coreSyn/MkCore.hs

@@ -752,8 +752,8 @@ pc_bottoming_Id1 name ty
         -- any pc_bottoming_Id will itself have CafRefs, which bloats
         -- SRTs.
 
-    strict_sig = mkClosedStrictSig [evalDmd] botRes
-    -- These "bottom" out, no matter what their arguments
+    strict_sig = mkClosedStrictSig [evalDmd] exnRes
+                 -- exnRes: these throw an exception, not just diverge
 
 pc_bottoming_Id2 :: Name -> Type -> Id
 -- Same but arity two
@@ -762,4 +762,5 @@ pc_bottoming_Id2 name ty
  where
     bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
                                    `setArityInfo`      2
-    strict_sig = mkClosedStrictSig [evalDmd, evalDmd] botRes
+    strict_sig = mkClosedStrictSig [evalDmd, evalDmd] exnRes
+                 -- exnRes: these throw an exception, not just diverge

compiler/prelude/primops.txt.pp

@@ -1940,33 +1940,8 @@ Consider this example, which comes from GHC.IO.Handle.Internals:
 The outer case just decides whether to mask exceptions, but we don't want
 thereby to hide the strictness in 'ma'!  Hence the use of strictApply1Dmd.
 
-For catch, we know that the first branch will be evaluated, but not
-necessarily the second.  Hence strictApply1Dmd and lazyApply1Dmd
-
-Howver, consider
-    catch# (\st -> case x of ...) (..handler..) st
-We'll see that the entire thing is strict in 'x', so 'x' may be evaluated
-before the catch#.  So if evaluting 'x' causes a divide-by-zero exception,
-it won't be caught.  This seems acceptable:
-
-  - x might be evaluated somewhere else outside the catch# anyway
-  - It's an imprecise eception anyway.  Synchronous exceptions (in the
-    IO monad) will never move in this way.
-
-Unfortunately, there is a tricky wrinkle here, as pointed out in #10712.
-Consider,
-
-    let r = \st -> raiseIO# blah st
-    in catch (\st -> ...(r st)..) handler st
-
-If we give the first argument of catch a strict signature, we'll get
-a demand 'C(S)' for 'r'; that is, 'r' is definitely called with one
-argument, which indeed it is. The trouble comes when we feed 'C(S)'
-into 'r's RHS as the demand of the body as this will lead us to conclude that
-the whole 'let' will diverge; clearly this isn't right.
-
-There's something very special about catch: it turns divergence into
-non-divergence.
+For catch, we must be extra careful; see
+Note [Exceptions and strictness] in Demand
 -}
 
 primop  CatchOp "catch#" GenPrimOp
@@ -1975,7 +1950,9 @@ primop  CatchOp "catch#" GenPrimOp
        -> State# RealWorld
        -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [lazyApply1Dmd,lazyApply2Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
+                                                 , lazyApply2Dmd
+                                                 , topDmd] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -1984,8 +1961,8 @@ primop  RaiseOp "raise#" GenPrimOp
    b -> o
       -- NB: the type variable "o" is "a", but with OpenKind
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
-      -- NB: result is bottom
+   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
+      -- NB: result is ThrowsExn
    out_of_line = True
    has_side_effects = True
      -- raise# certainly throws a Haskell exception and hence has_side_effects
@@ -2006,7 +1983,7 @@ primop  RaiseOp "raise#" GenPrimOp
 primop  RaiseIOOp "raiseIO#" GenPrimOp
    a -> State# RealWorld -> (# State# RealWorld, b #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2079,7 +2056,9 @@ primop  CatchRetryOp "catchRetry#" GenPrimOp
    -> (State# RealWorld -> (# State# RealWorld, a #) )
    -> (State# RealWorld -> (# State# RealWorld, a #) )
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [lazyApply1Dmd,lazyApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
+                                                 , lazyApply1Dmd
+                                                 , topDmd ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2089,7 +2068,9 @@ primop  CatchSTMOp "catchSTM#" GenPrimOp
    -> (b -> State# RealWorld -> (# State# RealWorld, a #) )
    -> (State# RealWorld -> (# State# RealWorld, a #) )
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [lazyApply1Dmd,lazyApply2Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
+                                                 , lazyApply2Dmd
+                                                 , topDmd ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True

compiler/stgSyn/CoreToStg.hs

@@ -41,7 +41,7 @@ import FastString
 import Util
 import DynFlags
 import ForeignCall
-import Demand           ( isSingleUsed )
+import Demand           ( isUsedOnce )
 import PrimOp           ( PrimCall(..) )
 
 import Data.Maybe    (isJust)
@@ -833,8 +833,8 @@ mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
 
     (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
-    upd_flag | isSingleUsed (idDemandInfo bndr)  = SingleEntry
-             | otherwise                         = Updatable
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
 
   {-
     SDM: disabled.  Eval/Apply can't handle functions with arity zero very

compiler/stranal/DmdAnal.hs

@@ -115,9 +115,9 @@ dmdAnalStar :: AnalEnv
             -> Demand   -- This one takes a *Demand*
             -> CoreExpr -> (BothDmdArg, CoreExpr)
 dmdAnalStar env dmd e
-  | (cd, defer_and_use) <- toCleanDmd dmd (exprType e)
+  | (defer_and_use, cd) <- toCleanDmd dmd (exprType e)
   , (dmd_ty, e')        <- dmdAnal env cd e
-  = (postProcessDmdTypeM defer_and_use dmd_ty, e')
+  = (postProcessDmdType defer_and_use dmd_ty, e')
 
 -- Main Demand Analsysis machinery
 dmdAnal, dmdAnal' :: AnalEnv
@@ -197,10 +197,12 @@ dmdAnal' env dmd (Lam var body)
     (body_ty, Lam var body')
 
   | otherwise
-  = let (body_dmd, defer_and_use@(_,one_shot)) = peelCallDmd dmd
-          -- body_dmd  - a demand to analyze the body
-          -- one_shot  - one-shotness of the lambda
-          --             hence, cardinality of its free vars
+  = let (body_dmd, defer_and_use) = peelCallDmd dmd
+          -- body_dmd: a demand to analyze the body
+
+        one_shot         = useCount (getUseDmd defer_and_use)
+          -- one_shot: one-shotness of the lambda
+          --           hence, cardinality of its free vars
 
         env'             = extendSigsWithLam env var
         (body_ty, body') = dmdAnal env' body_dmd body

compiler/stranal/WorkWrap.hs

@@ -392,8 +392,9 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
                     -- The arity is set by the simplifier using exprEtaExpandArity
                     -- So it may be more than the number of top-level-visible lambdas
 
-    work_res_info | isBotRes res_info = botRes  -- Cpr stuff done by wrapper
-                  | otherwise         = topRes
+    work_res_info = case returnsCPR_maybe res_info of
+                       Just _  -> topRes    -- Cpr stuff done by wrapper; kill it here
+                       Nothing -> res_info  -- Preserve exception/divergence
 
     one_shots = get_one_shots rhs
 

testsuite/tests/deSugar/should_compile/T2431.stderr

@@ -55,7 +55,7 @@ T2431.$tc:~: =
 
 -- RHS size: {terms: 4, types: 8, coercions: 0}
 absurd :: forall a. Int :~: Bool -> a
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>b]
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>x]
 absurd = \ (@ a4) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
 
 

testsuite/tests/numeric/should_compile/T7116.stdout

@@ -35,7 +35,7 @@ dr :: Double -> Double
 [GblId,
  Arity=1,
  Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -54,7 +54,7 @@ dl :: Double -> Double
 [GblId,
  Arity=1,
  Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -69,7 +69,7 @@ fr :: Float -> Float
 [GblId,
  Arity=1,
  Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -88,7 +88,7 @@ fl :: Float -> Float
 [GblId,
  Arity=1,
  Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

testsuite/tests/simplCore/should_compile/T3772.stdout

@@ -16,7 +16,7 @@ end Rec }
 
 -- RHS size: {terms: 14, types: 5, coercions: 0}
 foo [InlPrag=NOINLINE] :: Int -> ()
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U(U)>]
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S(S),1*U(U)>]
 foo =
   \ (n :: Int) ->
     case n of _ [Occ=Dead] { GHC.Types.I# y ->

testsuite/tests/simplCore/should_compile/T4930.stderr

@@ -34,7 +34,7 @@ Rec {
 -- RHS size: {terms: 23, types: 6, coercions: 0}
 T4930.$wfoo [InlPrag=[0], Occ=LoopBreaker]
   :: GHC.Prim.Int# -> GHC.Prim.Int#
-[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>]
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,U>]
 T4930.$wfoo =
   \ (ww :: GHC.Prim.Int#) ->
     case case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# ww 5#)
@@ -53,7 +53,7 @@ foo [InlPrag=INLINE[0]] :: Int -> Int
 [GblId,
  Arity=1,
  Caf=NoCafRefs,
- Str=DmdType <S,1*U(U)>m,
+ Str=DmdType <S(S),1*U(U)>m,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

testsuite/tests/simplCore/should_compile/spec-inline.stderr

@@ -32,7 +32,7 @@ Roman.$trModule =
 
 -- RHS size: {terms: 2, types: 2, coercions: 0}
 Roman.foo3 :: Int
-[GblId, Str=DmdType b]
+[GblId, Str=DmdType x]
 Roman.foo3 =
   Control.Exception.Base.patError
     @ 'GHC.Types.Lifted

testsuite/tests/stranal/sigs/HyperStrUse.stderr

 
 ==================== Strictness signatures ====================
 HyperStrUse.$trModule: m
-HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m
+HyperStrUse.f: <S(S(S)L),1*U(1*U(U),A)><S,1*U>m
 
 

testsuite/tests/stranal/sigs/T8598.stderr

 
 ==================== Strictness signatures ====================
 T8598.$trModule: m
-T8598.fun: <S,1*U(U)>m
+T8598.fun: <S(S),1*U(U)>m
 
 

testsuite/tests/stranal/sigs/UnsatFun.stderr

 
 ==================== Strictness signatures ====================
 UnsatFun.$trModule: m
-UnsatFun.f: <B,1*U(U)><B,A>b
-UnsatFun.g: <B,1*U(U)>b
+UnsatFun.f: <B,1*U(U)><B,A>x
+UnsatFun.g: <B,1*U(U)>x
 UnsatFun.g': <L,1*U(U)>
 UnsatFun.g3: <L,U(U)>m
 UnsatFun.h: <C(S),1*C1(U(U))>