diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2022-07-12 16:06:24 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-07-18 16:38:04 -0400 |
| commit | ae3b3b62b422fc88a06ed06384caf27be91b1d37 (patch) | |
| tree | f4e8986c34413749db620e69adc9a3cee4415269 | |
| parent | 5f907371996735d13a4f9c87d235a18a68022e4e (diff) | |
| download | haskell-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.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id.hs | 9 |
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 |