diff options
| -rw-r--r-- | compiler/basicTypes/Demand.lhs | 7 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 10 |
2 files changed, 14 insertions, 3 deletions
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index fa706de994..ba635fcb1e 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -14,7 +14,7 @@ module Demand ( mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, getUsage, toCleanDmd, absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, + lubDmd, bothDmd, apply1Dmd, apply2Dmd, isTopDmd, isBotDmd, isAbsDmd, isSeqDmd, peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, @@ -467,6 +467,11 @@ mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as absDmd :: JointDmd absDmd = mkJointDmd Lazy Abs +apply1Dmd, apply2Dmd :: Demand +-- C1(U), C1(C1(U)) respectively +apply1Dmd = JD { strd = Lazy, absd = Use Many (UCall One Used) } +apply2Dmd = JD { strd = Lazy, absd = Use Many (UCall One (UCall One Used)) } + topDmd :: JointDmd topDmd = mkJointDmd Lazy useTop diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 7457583686..b3cf2f424d 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1618,8 +1618,8 @@ primop CatchOp "catch#" GenPrimOp with -- Catch is actually strict in its first argument -- but we don't want to tell the strictness - -- analyser about that! - -- might use caught action multiply + -- analyser about that, so that exceptions stay inside it. + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1651,6 +1651,7 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1658,6 +1659,7 @@ primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1665,6 +1667,7 @@ primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1684,6 +1687,7 @@ primop AtomicallyOp "atomically#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld -> (# State# RealWorld, a #) with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1709,6 +1713,7 @@ primop CatchRetryOp "catchRetry#" GenPrimOp -> (State# RealWorld -> (# State# RealWorld, a #) ) -> (State# RealWorld -> (# State# RealWorld, a #) ) with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply1Dmd,topDmd] topRes } out_of_line = True has_side_effects = True @@ -1717,6 +1722,7 @@ primop CatchSTMOp "catchSTM#" GenPrimOp -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) -> (State# RealWorld -> (# State# RealWorld, a #) ) with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes } out_of_line = True has_side_effects = True |