[commit: ghc] wip/better-ho-cardinality: Assign strictness signatures to primitive operations (32d3b73)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/better-ho-cardinality
Link       : http://ghc.haskell.org/trac/ghc/changeset/32d3b73423923adc40ac7cc867d9930b1d474240/ghc

>---------------------------------------------------------------

commit 32d3b73423923adc40ac7cc867d9930b1d474240
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Dec 11 18:18:53 2013 +0000

    Assign strictness signatures to primitive operations
    
    This patch was authored by SPJ, and extracted from "Improve the handling
    of used-once stuff" by Joachim.


>---------------------------------------------------------------

32d3b73423923adc40ac7cc867d9930b1d474240
 compiler/basicTypes/Demand.lhs  |    7 ++++++-
 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 8249748..9c87bb7 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,
 
@@ -465,6 +465,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 37591af..34a5ef3 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 -> mkStrictSig (mkTopDmdType [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 -> mkStrictSig (mkTopDmdType [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 -> mkStrictSig (mkTopDmdType [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 -> mkStrictSig (mkTopDmdType [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 -> mkStrictSig (mkTopDmdType [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 -> mkStrictSig (mkTopDmdType [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 -> mkStrictSig (mkTopDmdType [apply1Dmd,apply2Dmd,topDmd] topRes) }
    out_of_line = True
    has_side_effects = True