Commit 0558911f authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Joachim Breitner
Browse files

Assign strictness signatures to primitive operations

This patch was authored by SPJ, and extracted from "Improve the handling
of used-once stuff" by Joachim.
parent ba78bf17
......@@ -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
......
......@@ -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
......
Supports Markdown
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