Assign strictness signatures to primitive operations
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 11 Dec 2013 18:18:53 +0000 (18:18 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 12 Dec 2013 11:26:58 +0000 (11:26 +0000)
This patch was authored by SPJ, and extracted from "Improve the handling
of used-once stuff" by Joachim.

compiler/basicTypes/Demand.lhs
compiler/prelude/primops.txt.pp

index fa706de..ba635fc 100644 (file)
@@ -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
 
index 7457583..b3cf2f4 100644 (file)
@@ -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