Commit 9915b656 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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
parent a5cea73c
This diff is collapsed.
......@@ -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]
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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] { }
......
......@@ -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)
......
......@@ -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 ->
......
......@@ -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)
......
......@@ -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
......
==================== 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
==================== Strictness signatures ====================
T8598.$trModule: m
T8598.fun: <S,1*U(U)>m
T8598.fun: <S(S),1*U(U)>m
==================== 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))>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment