[Git][ghc/ghc][wip/T21623] More on boxing data cons
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Sep 12 12:42:04 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
d711fa4e by Simon Peyton Jones at 2022-09-12T13:41:37+01:00
More on boxing data cons
- - - - -
5 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Builtin/Uniques.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- libraries/ghc-prim/GHC/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Builtin.Types (
promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,
-- * Boxing primitive types
- boxingDataCon_maybe,
+ boxingDataCon_maybe, boxingDataConUnlifted_maybe,
-- * Char
charTyCon, charDataCon, charTyCon_RDR,
@@ -96,9 +96,6 @@ module GHC.Builtin.Types (
-- * Sums
mkSumTy, sumTyCon, sumDataCon,
- -- * data type Dict
- dictTyCon, mkDictDataCon,
-
-- * Kinds
typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName,
@@ -174,25 +171,30 @@ import GHC.Builtin.Uniques
-- others:
import GHC.Core.Coercion.Axiom
-import GHC.Types.Id
-import GHC.Types.TyThing
-import GHC.Types.SourceText
-import GHC.Types.Var ( VarBndr (Bndr) )
-import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
-import GHC.Unit.Module ( Module )
import GHC.Core.Type
-import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
-import GHC.Types.RepType
+import GHC.Types.Id
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Class ( Class, mkClass )
+import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )
+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
+
+import GHC.Types.TyThing
+import GHC.Types.SourceText
+import GHC.Types.Var ( VarBndr (Bndr) )
+import GHC.Types.RepType
import GHC.Types.Name.Reader
import GHC.Types.Name as Name
-import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )
+import GHC.Types.Name.Env ( lookupNameEnv_NF )
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.Unique.Set
+
+
+import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
+import GHC.Unit.Module ( Module )
+
import Data.Array
import GHC.Data.FastString
import GHC.Data.BooleanFormula ( mkAnd )
@@ -276,7 +278,8 @@ names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc
-- See also Note [Known-key names]
wiredInTyCons :: [TyCon]
-wiredInTyCons = [ -- Units are not treated like other tuples, because they
+wiredInTyCons = map (dataConTyCon . snd) boxingDataCons
+ ++ [ -- Units are not treated like other tuples, because they
-- are defined in GHC.Base, and there's only a few of them. We
-- put them in wiredInTyCons so that they will pre-populate
-- the name cache, so the parser in isBuiltInOcc_maybe doesn't
@@ -320,7 +323,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
, unliftedRepTyCon
, zeroBitRepTyCon
, zeroBitTypeTyCon
- , dictTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -508,40 +510,6 @@ typeSymbolKindConName :: Name
typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon
-runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name
-runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
-vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon
-tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon
-sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon
-boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon
-
-vecCountTyConName :: Name
-vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon
-
--- See Note [Wiring in RuntimeRep]
-vecCountDataConNames :: [Name]
-vecCountDataConNames = zipWith3Lazy mk_special_dc_name
- [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8"
- , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ]
- vecCountDataConKeys
- vecCountDataCons
-
-vecElemTyConName :: Name
-vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon
-
--- See Note [Wiring in RuntimeRep]
-vecElemDataConNames :: [Name]
-vecElemDataConNames = zipWith3Lazy mk_special_dc_name
- [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep"
- , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep"
- , fsLit "Word32ElemRep", fsLit "Word64ElemRep"
- , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]
- vecElemDataConKeys
- vecElemDataCons
-
-mk_special_dc_name :: FastString -> Unique -> DataCon -> Name
-mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
-
boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,
intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
@@ -1182,24 +1150,6 @@ unboxedUnitTyCon = tupleTyCon Unboxed 0
unboxedUnitDataCon :: DataCon
unboxedUnitDataCon = tupleDataCon Unboxed 0
-
-dictTyConName, mkDictDataConName :: Name
-dictTyConName = mkWiredInTyConName UserSyntax gHC_MAGIC_DICT (fsLit "Dict")
- dictTyConKey dictTyCon
-
-mkDictDataConName = mkWiredInDataConName UserSyntax gHC_MAGIC_DICT (fsLit "MkDict")
- mkDictDataConKey mkDictDataCon
-
-dictTyCon :: TyCon
-dictTyCon = pcTyCon dictTyConName Nothing [alphaConstraintTyVar] [mkDictDataCon]
-
-mkDictDataCon :: DataCon
-mkDictDataCon = pcDataConConstraint mkDictDataConName
- [alphaConstraintTyVar]
- [alphaConstraintTy]
- dictTyCon
-
-
{- *********************************************************************
* *
Unboxed sums
@@ -1600,12 +1550,26 @@ See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.
runtimeRepTyCon :: TyCon
runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
+ -- Here we list all the data constructors
+ -- of the RuntimeRep data type
(vecRepDataCon : tupleRepDataCon :
- sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons)
+ sumRepDataCon : boxedRepDataCon :
+ runtimeRepSimpleDataCons)
runtimeRepTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
+runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name
+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
+
+vecRepDataConName = mk_runtime_rep_dc_name (fsLit "VecRep") vecRepDataConKey vecRepDataCon
+tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon
+sumRepDataConName = mk_runtime_rep_dc_name (fsLit "SumRep") sumRepDataConKey sumRepDataCon
+boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon
+
+mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name
+mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
+
boxedRepDataCon :: DataCon
boxedRepDataCon = pcSpecialDataCon boxedRepDataConName
[ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)
@@ -1656,53 +1620,31 @@ sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]
sumRepDataConTyCon :: TyCon
sumRepDataConTyCon = promoteDataCon sumRepDataCon
-vecRepDataCon :: DataCon
-vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
- , mkTyConTy vecElemTyCon ]
- runtimeRepTyCon
- (RuntimeRep prim_rep_fun)
- where
- -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
- prim_rep_fun [count, elem]
- | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)
- , VecElem e <- tyConPromDataConInfo (tyConAppTyCon elem)
- = [VecRep n e]
- prim_rep_fun args
- = pprPanic "vecRepDataCon" (ppr args)
-
-vecRepDataConTyCon :: TyCon
-vecRepDataConTyCon = promoteDataCon vecRepDataCon
-
-- See Note [Wiring in RuntimeRep]
-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
runtimeRepSimpleDataCons :: [DataCon]
runtimeRepSimpleDataCons
- = zipWithLazy mk_runtime_rep_dc
- [ IntRep
- , Int8Rep, Int16Rep, Int32Rep, Int64Rep
- , WordRep
- , Word8Rep, Word16Rep, Word32Rep, Word64Rep
- , AddrRep
- , FloatRep, DoubleRep
- ]
- runtimeRepSimpleDataConNames
+ = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys
+ [ (fsLit "IntRep", IntRep)
+ , (fsLit "Int8Rep", Int8Rep)
+ , (fsLit "Int16Rep", Int16Rep)
+ , (fsLit "Int32Rep", Int32Rep)
+ , (fsLit "Int64Rep", Int64Rep)
+ , (fsLit "WordRep", WordRep)
+ , (fsLit "Word8Rep", Word8Rep)
+ , (fsLit "Word16Rep", Word16Rep)
+ , (fsLit "Word32Rep", Word32Rep)
+ , (fsLit "Word64Rep", Word64Rep)
+ , (fsLit "AddrRep", AddrRep)
+ , (fsLit "FloatRep", FloatRep)
+ , (fsLit "DoubleRep", DoubleRep) ]
where
- mk_runtime_rep_dc primrep name
- = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))
-
--- See Note [Wiring in RuntimeRep]
-runtimeRepSimpleDataConNames :: [Name]
-runtimeRepSimpleDataConNames
- = zipWith3Lazy mk_special_dc_name
- [ fsLit "IntRep"
- , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"
- , fsLit "WordRep"
- , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"
- , fsLit "AddrRep"
- , fsLit "FloatRep", fsLit "DoubleRep"
- ]
- runtimeRepSimpleDataConKeys
- runtimeRepSimpleDataCons
+ mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon
+ mk_runtime_rep_dc uniq (fs, primrep)
+ = data_con
+ where
+ data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))
+ dc_name = mk_runtime_rep_dc_name fs uniq data_con
-- See Note [Wiring in RuntimeRep]
intRepDataConTy,
@@ -1787,6 +1729,47 @@ unliftedRepTy = mkTyConTy unliftedRepTyCon
* *
********************************************************************* -}
+vecCountTyConName :: Name
+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon
+
+-- See Note [Wiring in RuntimeRep]
+vecCountDataConNames :: [Name]
+vecCountDataConNames = zipWith3Lazy mk_runtime_rep_dc_name
+ [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8"
+ , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ]
+ vecCountDataConKeys
+ vecCountDataCons
+
+vecElemTyConName :: Name
+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon
+
+-- See Note [Wiring in RuntimeRep]
+vecElemDataConNames :: [Name]
+vecElemDataConNames = zipWith3Lazy mk_runtime_rep_dc_name
+ [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep"
+ , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep"
+ , fsLit "Word32ElemRep", fsLit "Word64ElemRep"
+ , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]
+ vecElemDataConKeys
+ vecElemDataCons
+
+vecRepDataCon :: DataCon
+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
+ , mkTyConTy vecElemTyCon ]
+ runtimeRepTyCon
+ (RuntimeRep prim_rep_fun)
+ where
+ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
+ prim_rep_fun [count, elem]
+ | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)
+ , VecElem e <- tyConPromDataConInfo (tyConAppTyCon elem)
+ = [VecRep n e]
+ prim_rep_fun args
+ = pprPanic "vecRepDataCon" (ppr args)
+
+vecRepDataConTyCon :: TyCon
+vecRepDataConTyCon = promoteDataCon vecRepDataCon
+
vecCountTyCon :: TyCon
vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons
@@ -1918,28 +1901,97 @@ doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
* *
********************************************************************* -}
-{- Note [Boxing primitive types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a handful of primitive types (Int, Char, Word, Float, Double),
-we can readily box and an unboxed version (Int#, Char# etc) using
-the corresponding data constructor. This is useful in a couple
-of places, notably let-floating -}
-
-boxingDataCon_maybe :: TyCon -> Maybe DataCon
--- boxingDataCon_maybe Char# = C#
--- boxingDataCon_maybe Int# = I#
--- ... etc ...
--- See Note [Boxing primitive types]
-boxingDataCon_maybe tc
- = lookupNameEnv boxing_constr_env (tyConName tc)
-
-boxing_constr_env :: NameEnv DataCon
-boxing_constr_env
- = mkNameEnv [(charPrimTyConName , charDataCon )
- ,(intPrimTyConName , intDataCon )
- ,(wordPrimTyConName , wordDataCon )
- ,(floatPrimTyConName , floatDataCon )
- ,(doublePrimTyConName, doubleDataCon) ]
+{- Note [Boxing constructors}
+
+In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep
+that "box" unlifted values into a (boxed, lifted) value of kind Type. For example
+
+ type IntBox :: TYPE IntRep -> Type
+ data IntBox (a :: TYPE IntRep) = MkIntBox a
+ -- MkIntBox :: forall (a :: TYPE IntRep). a -> IntBox a
+
+Then we can package an `Int#` into an `IntBox` with `MkIntBox`. We can also
+package up a (lifted) Constraint as a value of kind Type.
+
+This is used:
+
+* In desugaring, when we need to package up a bunch of values into a tuple,
+ for example when desugaring arrows. See Note [Big tuples] in GHC.Core.Make.
+
+* In let-floating when we want to float an unlifted sub-expression.
+ See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels
+
+Here we make wired-in data type declarations for all of these boxing functions.
+The goal is to define boxingDataCon_maybe.
+-}
+
+boxingDataCon_maybe :: HasDebugCallStack => Type -> Maybe (DataCon, Type)
+-- This variant panics if it is given an unlifted type
+-- that it does not know how to box.
+boxingDataCon_maybe ty
+ | tcIsLiftedTypeKind kind
+ = Nothing -- Fast path
+ | Just box_con <- lookupTypeMap boxingDataConMap kind
+ = Just (box_con, mkTyConApp (dataConTyCon box_con) [ty])
+ | otherwise
+ = pprPanic "boxingDataCon_maybe" (ppr ty <+> dcolon <+> ppr kind)
+ where
+ kind = typeKind ty
+
+boxingDataConUnlifted_maybe :: HasDebugCallStack => Type -> Maybe (DataCon, Type)
+-- This variant expects the type to be unlifted, and does not
+-- fail if there is no suitable DataCon; used in SetLevels
+boxingDataConUnlifted_maybe ty
+ | Just box_con <- lookupTypeMap boxingDataConMap kind
+ = Just (box_con, mkTyConApp (dataConTyCon box_con) [ty])
+ | otherwise
+ = Nothing
+ where
+ kind = typeKind ty
+
+boxingDataConMap :: TypeMap DataCon
+boxingDataConMap = foldl add emptyTypeMap boxingDataCons
+ where
+ add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con
+
+boxingDataCons :: [(Kind, DataCon)]
+-- The TyCon is the RuntimeRep for which the DataCon is the right boxing
+boxingDataCons = zipWith mkBoxingDataCon
+ (map mkBoxingTyConUnique [1..])
+ [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox")
+ , (mkTYPEapp intRepDataConTy, fsLit "IntBox", fsLit "MkIntBox")
+
+ , (mkTYPEapp floatRepDataConTy, fsLit "FloatBox", fsLit "MkFloatBox")
+ , (mkTYPEapp doubleRepDataConTy, fsLit "DoubleBox", fsLit "MkDoubleBox")
+
+ , (mkTYPEapp int8RepDataConTy, fsLit "Int8Box", fsLit "MkInt8Box")
+ , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box")
+ , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box")
+ , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box")
+
+ , (mkTYPEapp word8RepDataConTy, fsLit "Word8Box", fsLit "MkWord8Box")
+ , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box", fsLit "MkWord16Box")
+ , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box", fsLit "MkWord32Box")
+ , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box", fsLit "MkWord64Box")
+
+ , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox")
+ , (constraintKind, fsLit "DictBox", fsLit "MkDictBox") ]
+
+mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon)
+mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc)
+ = (kind, dc)
+ where
+ uniq_dc = boxingDataConUnique uniq_tc
+
+ (tv:_) = mkTemplateTyVars (repeat kind)
+ tc = pcTyCon tc_name Nothing [tv] [dc]
+ tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc
+
+ dc | isConstraintKind kind
+ = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc
+ | otherwise
+ = pcDataCon dc_name [tv] [mkTyVarTy tv] tc
+ dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc
{-
************************************************************************
=====================================
compiler/GHC/Builtin/Uniques.hs
=====================================
@@ -13,8 +13,8 @@ module GHC.Builtin.Uniques
-- * Getting the 'Unique's of 'Name's
-- ** Anonymous sums
- , mkSumTyConUnique
- , mkSumDataConUnique
+ , mkSumTyConUnique, mkSumDataConUnique
+
-- ** Tuples
-- *** Vanilla
, mkTupleTyConUnique
@@ -45,6 +45,9 @@ module GHC.Builtin.Uniques
, initExitJoinUnique
+ -- Boxing data types
+ , mkBoxingTyConUnique, boxingDataConUnique
+
) where
import GHC.Prelude
@@ -297,6 +300,7 @@ Allocation of unique supply characters:
other a-z: lower case chars for unique supplies. Used so far:
a TypeChecking?
+ b RuntimeRep
c StgToCmm/Renamer
d desugarer
f AbsC flattener
@@ -351,7 +355,6 @@ mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs)
initExitJoinUnique :: Unique
initExitJoinUnique = mkUnique 's' 0
-
--------------------------------------------------
-- Wired-in type constructor keys occupy *two* slots:
-- * u: the TyCon itself
@@ -373,7 +376,22 @@ tyConRepNameUnique u = incrUnique u
mkPreludeDataConUnique :: Int -> Unique
mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
---------------------------------------------------
dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
dataConTyRepNameUnique u = stepUnique u 2
+
+--------------------------------------------------
+-- The data constructors of RuntimeRep occupy *six* slots:
+-- Example: WordRep
+--
+-- * u: the TyCon of the boxing data type WordBox
+-- * u+1: the TyConRepName of the boxing data type
+-- * u+2: the DataCon for MkWordBox
+-- * u+3: the worker id for MkWordBox
+-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox
+
+mkBoxingTyConUnique :: Int -> Unique
+mkBoxingTyConUnique i = mkUnique 'b' (5*i)
+
+boxingDataConUnique :: Unique -> Unique
+boxingDataConUnique u = stepUnique u 2
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -478,8 +478,10 @@ wrapBox :: CoreExpr -> CoreExpr
-- But if (ty :: Constraint), returns (MkDict @ty e)
-- which has kind Type
wrapBox e
- | isPredTy e_ty = mkCoreConApps mkDictDataCon [Type e_ty, e]
- | otherwise = e
+ | Just (boxing_con, _) <- boxingDataCon_maybe e_ty
+ = mkCoreConApps boxing_con [Type e_ty, e]
+ | otherwise
+ = e
where
e_ty = exprType e
@@ -487,9 +489,10 @@ boxTy :: Type -> Type
-- If (ty :: Type) then boxTy is a no-op
-- but if (ty :: Constraint), boxTy returns (Dict ty)
boxTy ty
- | isPredTy ty = assertPpr (not (isUnliftedType ty)) (ppr ty) $
- mkTyConApp dictTyCon [ty]
- | otherwise = ty
+ | Just (_, box_ty) <- boxingDataCon_maybe ty
+ = box_ty
+ | otherwise
+ = ty
unwrapBox :: UniqSupply -> Id -> CoreExpr
-> (UniqSupply, Id, CoreExpr)
@@ -497,15 +500,15 @@ unwrapBox :: UniqSupply -> Id -> CoreExpr
-- returns (case v' of MkDict v -> body)
-- together with v'
unwrapBox us var body
- | isPredTy var_ty = (us', var', body')
- | otherwise = (us, var, body)
- where
- (uniq, us') = takeUniqFromSupply us
- var_ty = idType var
- var' = mkSysLocal (fsLit "uc") uniq ManyTy (boxTy var_ty)
- body' = Case (Var var') var' (exprType body)
- [Alt (DataAlt mkDictDataCon) [var] body]
+ | let var_ty = idType var
+ , Just (box_con, box_ty) <- boxingDataCon_maybe var_ty
+ , let var' = mkSysLocal (fsLit "uc") uniq ManyTy box_ty
+ body' = Case (Var var') var' (exprType body)
+ [Alt (DataAlt box_con) [var] body]
+ (uniq, us') = takeUniqFromSupply us
+ = (us', var', body')
+ | otherwise = (us, var, body)
-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition
mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -88,12 +88,11 @@ import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr )
import GHC.Core.FVs -- all of it
import GHC.Core.Subst
import GHC.Core.Make ( sortQuantVars )
-import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType
+import GHC.Core.Type ( Type, tyCoVarsOfType
, mightBeUnliftedType, closeOverKindsDSet
, typeHasFixedRuntimeRep
)
import GHC.Core.Multiplicity ( pattern ManyTy )
-import GHC.Core.DataCon ( dataConOrigResTy )
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -673,21 +672,19 @@ lvlMFE env strict_ctxt ann_expr
| escapes_value_lam
, not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions
-- See Note [Test cheapness with exprOkForSpeculation]
- , Just (tc, _) <- splitTyConApp_maybe expr_ty
- , Just dc <- boxingDataCon_maybe tc
- , let dc_res_ty = dataConOrigResTy dc -- No free type variables
- [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]
+ , Just (box_dc, box_ty) <- boxingDataConUnlifted_maybe expr_ty
+ , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]
= do { expr1 <- lvlExpr rhs_env ann_expr
; let l1r = incMinorLvlFrom rhs_env
float_rhs = mkLams abs_vars_w_lvls $
- Case expr1 (stayPut l1r ubx_bndr) dc_res_ty
- [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])]
+ Case expr1 (stayPut l1r ubx_bndr) box_ty
+ [Alt DEFAULT [] (mkConApp box_dc [Type expr_ty, Var ubx_bndr])]
; var <- newLvlVar float_rhs Nothing is_mk_static
; let l1u = incMinorLvlFrom env
use_expr = Case (mkVarApps (Var var) abs_vars)
(stayPut l1u bx_bndr) expr_ty
- [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]
+ [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]
; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
use_expr) }
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -514,12 +514,25 @@ type Void# = (# #)
-- These "boxing" data types allow us to wrap up a value of kind (TYPE rr)
-- in a box of kind Type, for each rr.
-data WordBox (a :: TYPE WordRep) = MkWordBox a
-data IntBox (a :: TYPE IntRep) = MkIntBox a
-data FloatBox (a :: TYPE FloatRep) = MkFloatBox a
-data DoubleBox (a :: TYPE DoubleRep) = MkDoubleBox a
+data LiftBox (a :: TYPE UnliftedRep) = MkLiftBox a
--- | Data type `Dict` provides a simple way to wrap up constraint as a type
+data IntBox (a :: TYPE IntRep) = MkIntBox a
+data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a
+data Int16Box (a :: TYPE Int16Rep) = MkInt16Box a
+data Int32Box (a :: TYPE Int32Rep) = MkInt32Box a
+data Int64Box (a :: TYPE Int64Rep) = MkInt64Box a
+
+data WordBox (a :: TYPE WordRep) = MkWordBox a
+data Word8Box (a :: TYPE Word8Rep) = MkWord8Box a
+data Word16Box (a :: TYPE Word16Rep) = MkWord16Box a
+data Word32Box (a :: TYPE Word32Rep) = MkWord32Box a
+data Word64Box (a :: TYPE Word64Rep) = MkWord64Box a
+
+data FloatBox (a :: TYPE FloatRep) = MkFloatBox a
+data DoubleBox (a :: TYPE DoubleRep) = MkDoubleBox a
+
+-- | Data type `Dict` provides a simple way to wrap up a (lifted)
+-- constraint as a type
data DictBox c where
MkDictBox :: c => DictBox c
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d711fa4ebc3b29494bf96ddd5415cdb2ff79565b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d711fa4ebc3b29494bf96ddd5415cdb2ff79565b
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/20220912/c450f4a9/attachment-0001.html>
More information about the ghc-commits
mailing list