diff options
author | Ben Gamari <ben@smart-cactus.org> | 2022-10-13 18:17:13 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2022-10-19 10:06:10 -0400 |
commit | 6148bd126c4602d011e7dd458288c02db1c16dc6 (patch) | |
tree | 0cebae532fef06af2374485530549273cee14bac | |
parent | 1ef412dde750d4ffd01a332e555ed4503d4eda85 (diff) | |
download | haskell-wip/T22291.tar.gz |
codeGen: Allow levity-polymorphic primop resultswip/T22291
Consider a program such as:
```haskell
foo :: forall (lev :: Levity) (a :: TYPE (BoxedRep lev)). Addr# -> (# a #)
foo x = addrToAny# x
```
While this program is accepted by the type-checker, the code generator would previously
choke on it due the levity polymorphism of `foo`'s result. Specifically,
`boxedRepDataCon` would fail as it was unable to determine the result's `PrimRep`
while trying to identify its Cmm type:
```
<no location info>: error:
panic! (the 'impossible' happened)
GHC version 9.5.20220906:
boxedRepDataCon
[lev_ayH]
Call stack:
CallStack (from HasCallStack):
callStackDoc, called at compiler/GHC/Utils/Panic.hs:188:37 in ghc:GHC.Utils.Panic
pprPanic, called at compiler/GHC/Builtin/Types.hs:1629:9 in ghc:GHC.Builtin.Types
prim_rep_fun, called at compiler/GHC/Builtin/Types.hs:1618:44 in ghc:GHC.Builtin.Types
fun, called at compiler/GHC/Types/RepType.hs:615:5 in ghc:GHC.Types.RepType
runtimeRepPrimRep, called at compiler/GHC/Builtin/Types.hs:1660:20 in ghc:GHC.Builtin.Types
prim_rep_fun, called at compiler/GHC/Builtin/Types.hs:1655:64 in ghc:GHC.Builtin.Types
fun, called at compiler/GHC/Types/RepType.hs:615:5 in ghc:GHC.Types.RepType
runtimeRepPrimRep, called at compiler/GHC/Types/RepType.hs:585:5 in ghc:GHC.Types.RepType
kindPrimRep, called at compiler/GHC/Types/RepType.hs:537:18 in ghc:GHC.Types.RepType
typePrimRep, called at compiler/GHC/StgToCmm/Utils.hs:305:58 in ghc:GHC.StgToCmm.Utils
newUnboxedTupleRegs, called at compiler/GHC/StgToCmm/Prim.hs:1701:33 in ghc:GHC.StgToCmm.Prim
```
Here we fix this by modifying `PrimRep` to reflect the fact that we may
know that a value is boxed without knowing its particular levity:
```haskell
data PrimRep = BoxedRep Levity | IntRep | ...
```
This allows `kindPrimRep (TYPE (BoxedRep lev))` to return
`BoxedRep _|_`, which is enough information for the code generator to
compile `foo`.
Fixes #22291.
-rw-r--r-- | compiler/GHC/Builtin/Types.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Utils.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCon.hs | 21 | ||||
-rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/StgToByteCode.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/ArgRep.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Lit.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/RepType.hs | 85 | ||||
-rw-r--r-- | testsuite/tests/codeGen/should_compile/all.T | 2 |
10 files changed, 72 insertions, 79 deletions
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 85bdd334c9..894c4cb7bb 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -1620,10 +1620,12 @@ boxedRepDataCon = pcSpecialDataCon boxedRepDataConName where -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [lev] - = case tyConRuntimeRepInfo (tyConAppTyCon lev) of - LiftedInfo -> [LiftedRep] - UnliftedInfo -> [UnliftedRep] - _ -> pprPanic "boxedRepDataCon" (ppr lev) + = [BoxedRep lev'] + where + lev' = case tyConRuntimeRepInfo (tyConAppTyCon lev) of + LiftedInfo -> Lifted + UnliftedInfo -> Unlifted + _ -> pprPanic "boxedRepDataCon(levity polymorphic)" (ppr lev) prim_rep_fun args = pprPanic "boxedRepDataCon" (ppr args) diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 3671366d07..c657a287df 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -98,8 +98,7 @@ import GHC.Cmm.Dataflow.Collections primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case VoidRep -> panic "primRepCmmType:VoidRep" - LiftedRep -> gcWord platform - UnliftedRep -> gcWord platform + BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform Int8Rep -> b8 @@ -141,8 +140,7 @@ typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) primRepForeignHint :: PrimRep -> ForeignHint primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" -primRepForeignHint LiftedRep = AddrHint -primRepForeignHint UnliftedRep = AddrHint +primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint primRepForeignHint Int16Rep = SignedHint diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 5ae1e2bf6b..75eeafcb00 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -1629,8 +1629,7 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep = VoidRep - | LiftedRep - | UnliftedRep -- ^ Unlifted pointer + | BoxedRep Levity | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value | Int32Rep -- ^ Signed, 32-bit value @@ -1668,8 +1667,8 @@ instance Outputable PrimElemRep where instance Binary PrimRep where put_ bh VoidRep = putByte bh 0 - put_ bh LiftedRep = putByte bh 1 - put_ bh UnliftedRep = putByte bh 2 + put_ bh (BoxedRep Lifted) = putByte bh 1 + put_ bh (BoxedRep Unlifted) = putByte bh 2 put_ bh Int8Rep = putByte bh 3 put_ bh Int16Rep = putByte bh 4 put_ bh Int32Rep = putByte bh 5 @@ -1688,8 +1687,8 @@ instance Binary PrimRep where h <- getByte bh case h of 0 -> pure VoidRep - 1 -> pure LiftedRep - 2 -> pure UnliftedRep + 1 -> pure (BoxedRep Lifted) + 2 -> pure (BoxedRep Unlifted) 3 -> pure Int8Rep 4 -> pure Int16Rep 5 -> pure Int32Rep @@ -1715,9 +1714,8 @@ isVoidRep VoidRep = True isVoidRep _other = False isGcPtrRep :: PrimRep -> Bool -isGcPtrRep LiftedRep = True -isGcPtrRep UnliftedRep = True -isGcPtrRep _ = False +isGcPtrRep (BoxedRep _) = True +isGcPtrRep _ = False -- A PrimRep is compatible with another iff one can be coerced to the other. -- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. @@ -1758,10 +1756,9 @@ primRepSizeB platform = \case FloatRep -> fLOAT_SIZE DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform - LiftedRep -> platformWordSizeInBytes platform - UnliftedRep -> platformWordSizeInBytes platform + BoxedRep _ -> platformWordSizeInBytes platform VoidRep -> 0 - (VecRep len rep) -> len * primElemRepSizeB platform rep + VecRep len rep -> len * primElemRepSizeB platform rep primElemRepSizeB :: Platform -> PrimElemRep -> Int primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 4956920fb1..d1b44e94fa 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -74,6 +74,7 @@ import Data.ByteString ( ByteString ) import Data.Data ( Data ) import Data.List ( intersperse ) import GHC.Core.DataCon +import GHC.Types.Basic ( Levity(..) ) import GHC.Types.ForeignCall ( ForeignCall ) import GHC.Types.Id import GHC.Types.Name ( isDynLinkName ) @@ -165,10 +166,10 @@ isDllConApp platform ext_dyn_refs this_mod con args -- -- The coercion argument here gets VoidRep isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep LiftedRep = True -isAddrRep UnliftedRep = True -isAddrRep _ = False +isAddrRep AddrRep = True +isAddrRep (BoxedRep Lifted) = True +isAddrRep (BoxedRep Unlifted) = True +isAddrRep _ = False -- | Type of an @StgArg@ -- diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index be2d6a82fa..879eaa1f61 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -1107,8 +1107,8 @@ layoutTuple profile start_off arg_ty reps = usePlainReturn :: Type -> Bool usePlainReturn t | isUnboxedTupleType t || isUnboxedSumType t = False - | otherwise = typePrimRep t == [LiftedRep] || - (typePrimRep t == [UnliftedRep] && isAlgType t) + | otherwise = typePrimRep t == [BoxedRep Lifted] || + (typePrimRep t == [BoxedRep Unlifted] && isAlgType t) {- Note [unboxed tuple bytecodes and tuple_BCO] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1451,8 +1451,7 @@ primRepToFFIType platform r AddrRep -> FFIPointer FloatRep -> FFIFloat DoubleRep -> FFIDouble - LiftedRep -> FFIPointer - UnliftedRep -> FFIPointer + BoxedRep _ -> FFIPointer _ -> pprPanic "primRepToFFIType" (ppr r) where (signed_word, unsigned_word) = case platformWordSize platform of @@ -1477,8 +1476,7 @@ mkDummyLiteral platform pr AddrRep -> LitNullAddr DoubleRep -> LitDouble 0 FloatRep -> LitFloat 0 - LiftedRep -> LitNullAddr - UnliftedRep -> LitNullAddr + BoxedRep _ -> LitNullAddr _ -> pprPanic "mkDummyLiteral" (ppr pr) diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index 9db0ed7afc..773195b6db 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -69,8 +69,7 @@ argRepString V64 = "V64" toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of VoidRep -> V - LiftedRep -> P - UnliftedRep -> P + BoxedRep _ -> P IntRep -> N WordRep -> N Int8Rep -> N -- Gets widened to native word width for calls diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs index 318c091a58..cd4bf7501f 100644 --- a/compiler/GHC/StgToCmm/Lit.hs +++ b/compiler/GHC/StgToCmm/Lit.hs @@ -53,8 +53,7 @@ cgLit (LitString s) = cgLit (LitRubbish rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] VoidRep -> panic "cgLit:VoidRep" -- ditto - LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId - UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId + BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do platform <- getPlatform diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index d4dcf3cb69..8a254cb182 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -1943,7 +1943,7 @@ isKindLevel KindLevel = True data Levity = Lifted | Unlifted - deriving Eq + deriving (Data, Eq, Ord, Show) instance Outputable Levity where ppr Lifted = text "Lifted" diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 993694e1c3..f37c033960 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -29,7 +29,7 @@ module GHC.Types.RepType import GHC.Prelude -import GHC.Types.Basic (Arity, RepArity) +import GHC.Types.Basic (Arity, RepArity, Levity(..)) import GHC.Core.DataCon import GHC.Builtin.Names import GHC.Core.Coercion @@ -310,27 +310,27 @@ typeSlotTy ty = Just (primRepSlot (typePrimRep1 ty)) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") -primRepSlot LiftedRep = PtrLiftedSlot -primRepSlot UnliftedRep = PtrUnliftedSlot -primRepSlot IntRep = WordSlot -primRepSlot Int8Rep = WordSlot -primRepSlot Int16Rep = WordSlot -primRepSlot Int32Rep = WordSlot -primRepSlot Int64Rep = Word64Slot -primRepSlot WordRep = WordSlot -primRepSlot Word8Rep = WordSlot -primRepSlot Word16Rep = WordSlot -primRepSlot Word32Rep = WordSlot -primRepSlot Word64Rep = Word64Slot -primRepSlot AddrRep = WordSlot -primRepSlot FloatRep = FloatSlot -primRepSlot DoubleRep = DoubleSlot -primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") +primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") +primRepSlot (BoxedRep Lifted) = PtrLiftedSlot +primRepSlot (BoxedRep Unlifted) = PtrUnliftedSlot +primRepSlot IntRep = WordSlot +primRepSlot Int8Rep = WordSlot +primRepSlot Int16Rep = WordSlot +primRepSlot Int32Rep = WordSlot +primRepSlot Int64Rep = Word64Slot +primRepSlot WordRep = WordSlot +primRepSlot Word8Rep = WordSlot +primRepSlot Word16Rep = WordSlot +primRepSlot Word32Rep = WordSlot +primRepSlot Word64Rep = Word64Slot +primRepSlot AddrRep = WordSlot +primRepSlot FloatRep = FloatSlot +primRepSlot DoubleRep = DoubleSlot +primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") slotPrimRep :: SlotTy -> PrimRep -slotPrimRep PtrLiftedSlot = LiftedRep -slotPrimRep PtrUnliftedSlot = UnliftedRep +slotPrimRep PtrLiftedSlot = BoxedRep Lifted +slotPrimRep PtrUnliftedSlot = BoxedRep Unlifted slotPrimRep Word64Slot = Word64Rep slotPrimRep WordSlot = WordRep slotPrimRep DoubleSlot = DoubleRep @@ -391,11 +391,10 @@ needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer - | UnliftedRep -- ^ Unlifted pointer - | Int8Rep -- ^ Signed, 8-bit value - | Int16Rep -- ^ Signed, 16-bit value + = VoidRep -- See Note [VoidRep] + | BoxedRep Levity -- ^ A pointer to a boxed value + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value ...etc... | VecRep Int PrimElemRep -- ^ SIMD fixed-width vector @@ -633,23 +632,23 @@ runtimeRepPrimRep_maybe rr_ty -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy - LiftedRep -> liftedRepTy - UnliftedRep -> unliftedRepTy - IntRep -> intRepDataConTy - Int8Rep -> int8RepDataConTy - Int16Rep -> int16RepDataConTy - Int32Rep -> int32RepDataConTy - Int64Rep -> int64RepDataConTy - WordRep -> wordRepDataConTy - Word8Rep -> word8RepDataConTy - Word16Rep -> word16RepDataConTy - Word32Rep -> word32RepDataConTy - Word64Rep -> word64RepDataConTy - AddrRep -> addrRepDataConTy - FloatRep -> floatRepDataConTy - DoubleRep -> doubleRepDataConTy - VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] + VoidRep -> zeroBitRepTy + BoxedRep Lifted -> liftedRepTy + BoxedRep Unlifted -> unliftedRepTy + IntRep -> intRepDataConTy + Int8Rep -> int8RepDataConTy + Int16Rep -> int16RepDataConTy + Int32Rep -> int32RepDataConTy + Int64Rep -> int64RepDataConTy + WordRep -> wordRepDataConTy + Word8Rep -> word8RepDataConTy + Word16Rep -> word16RepDataConTy + Word32Rep -> word32RepDataConTy + Word64Rep -> word64RepDataConTy + AddrRep -> addrRepDataConTy + FloatRep -> floatRepDataConTy + DoubleRep -> doubleRepDataConTy + VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] where n' = case n of 2 -> vec2DataConTy @@ -687,7 +686,7 @@ mightBeFunTy :: Type -> Bool -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty - | [LiftedRep] <- typePrimRep ty + | [BoxedRep Lifted] <- typePrimRep ty , Just tc <- tyConAppTyCon_maybe (unwrapType ty) , isDataTyCon tc = False diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T index 9538553c4e..eba3051a3f 100644 --- a/testsuite/tests/codeGen/should_compile/all.T +++ b/testsuite/tests/codeGen/should_compile/all.T @@ -112,4 +112,4 @@ test('T21710a', [ unless(tables_next_to_code(), skip) , when(wordsize(32), skip) , only_ways(['optasm']) , grep_errmsg('(call)',[1]) ] , compile, ['-ddump-cmm -dno-typeable-binds']) -test('T22291', expect_broken(22291), compile, ['']) +test('T22291', normal, compile, ['']) |