summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2022-07-12 16:06:24 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-07-18 16:38:04 -0400
commitae3b3b62b422fc88a06ed06384caf27be91b1d37 (patch)
treef4e8986c34413749db620e69adc9a3cee4415269
parent5f907371996735d13a4f9c87d235a18a68022e4e (diff)
downloadhaskell-ae3b3b62b422fc88a06ed06384caf27be91b1d37.tar.gz
Make transferPolyIdInfo work for CPR
I don't know why this hasn't bitten us before, but it was plain wrong.
-rw-r--r--compiler/GHC/Types/Cpr.hs10
-rw-r--r--compiler/GHC/Types/Id.hs9
2 files changed, 14 insertions, 5 deletions
diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs
index 2405b8f524..c486f24bd6 100644
--- a/compiler/GHC/Types/Cpr.hs
+++ b/compiler/GHC/Types/Cpr.hs
@@ -10,7 +10,8 @@ module GHC.Types.Cpr (
CprType (..), topCprType, botCprType, flatConCprType,
lubCprType, applyCprTy, abstractCprTy, trimCprTy,
UnpackConFieldsResult (..), unpackConFieldsCpr,
- CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig
+ CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig,
+ seqCprSig, prependArgsCprSig
) where
import GHC.Prelude
@@ -187,6 +188,13 @@ mkCprSig arty cpr = CprSig (CprType arty cpr)
seqCprSig :: CprSig -> ()
seqCprSig (CprSig ty) = seqCprTy ty
+prependArgsCprSig :: Arity -> CprSig -> CprSig
+-- ^ Add extra value args to CprSig
+prependArgsCprSig n_extra cpr_sig@(CprSig (CprType arity cpr))
+ | n_extra == 0 = cpr_sig
+ | otherwise = assertPpr (n_extra > 0) (ppr n_extra) $
+ CprSig (CprType (arity + n_extra) cpr)
+
-- | BNF:
--
-- > cpr ::= '' -- TopCpr
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 9fa38623a6..bab0ca01a6 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -1045,6 +1045,7 @@ transferPolyIdInfo old_id abstract_wrt new_id
old_strictness = dmdSigInfo old_info
new_strictness = prependArgsDmdSig arity_increase old_strictness
old_cpr = cprSigInfo old_info
+ new_cpr = prependArgsCprSig arity_increase old_cpr
old_cbv_marks = fromMaybe (replicate old_arity NotMarkedCbv) (idCbvMarks_maybe old_id)
abstr_cbv_marks = mapMaybe getMark abstract_wrt
@@ -1058,8 +1059,8 @@ transferPolyIdInfo old_id abstract_wrt new_id
, mightBeLiftedType (idType v)
= Just MarkedCbv
| otherwise = Just NotMarkedCbv
- transfer new_info = new_info `setArityInfo` new_arity
+ transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
- `setOccInfo` new_occ_info
- `setDmdSigInfo` new_strictness
- `setCprSigInfo` old_cpr
+ `setOccInfo` new_occ_info
+ `setDmdSigInfo` new_strictness
+ `setCprSigInfo` new_cpr