[Git][ghc/ghc][wip/T22291] 2 commits: testsuite: Add test case for #22291
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Wed Oct 19 14:06:19 UTC 2022
Ben Gamari pushed to branch wip/T22291 at Glasgow Haskell Compiler / GHC
Commits:
1ef412dd by Ben Gamari at 2022-10-19T10:06:09-04:00
testsuite: Add test case for #22291
- - - - -
6148bd12 by Ben Gamari at 2022-10-19T10:06:10-04:00
codeGen: Allow levity-polymorphic primop results
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.
- - - - -
11 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/ArgRep.hs
- compiler/GHC/StgToCmm/Lit.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/RepType.hs
- + testsuite/tests/codeGen/should_compile/T22291.hs
- testsuite/tests/codeGen/should_compile/all.T
Changes:
=====================================
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)
=====================================
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
=====================================
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
=====================================
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@
--
=====================================
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)
=====================================
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
=====================================
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
=====================================
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"
=====================================
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
=====================================
testsuite/tests/codeGen/should_compile/T22291.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+
+module T22291 where
+
+import GHC.Exts
+
+-- This should compile despite the levity polymorphism of foo's result
+foo :: forall (lev :: Levity) (a :: TYPE (BoxedRep lev)). Addr# -> (# a #)
+foo x = addrToAny# x
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -112,3 +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', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4265c5f96e3312d147d6615b7a60712ed2c099a6...6148bd126c4602d011e7dd458288c02db1c16dc6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4265c5f96e3312d147d6615b7a60712ed2c099a6...6148bd126c4602d011e7dd458288c02db1c16dc6
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221019/f40c04ea/attachment-0001.html>
More information about the ghc-commits
mailing list