[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