[Git][ghc/ghc][wip/T21623] Wrap dictionaries in tuples
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sun Sep 11 09:38:07 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
05f5d5f3 by Simon Peyton Jones at 2022-09-11T10:33:27+01:00
Wrap dictionaries in tuples
This fixes the kind bugs in arrow desugaring. Needs some Notes,
but I want to try CI.
- - - - -
14 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Iface/Binary.hs
- libraries/ghc-prim/GHC/Magic/Dict.hs
- libraries/ghc-prim/GHC/Types.hs
- testsuite/tests/ghci.debugger/scripts/break013.stdout
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -334,6 +334,9 @@ basicKnownKeyNames
fromListNName,
toListName,
+ -- Non-empty lists
+ nonEmptyTyConName,
+
-- Overloaded record dot, record update
getFieldName, setFieldName,
@@ -1411,7 +1414,10 @@ constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") con
-- WithDict
withDictClassName :: Name
-withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey
+withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey
+
+nonEmptyTyConName :: Name
+nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey
-- Custom type errors
errorMessageTypeErrorFamName
@@ -1896,6 +1902,9 @@ voidTyConKey = mkPreludeTyConUnique 85
nonEmptyTyConKey :: Unique
nonEmptyTyConKey = mkPreludeTyConUnique 86
+dictTyConKey :: Unique
+dictTyConKey = mkPreludeTyConUnique 87
+
-- Kind constructors
liftedTypeKindTyConKey, unliftedTypeKindTyConKey,
tYPETyConKey, cONSTRAINTTyConKey,
@@ -2077,8 +2086,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
floatDataConKey, intDataConKey, nilDataConKey,
ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
word8DataConKey, ioDataConKey, heqDataConKey,
- coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey,
- nonEmptyDataConKey :: Unique
+ eqDataConKey, nothingDataConKey, justDataConKey :: Unique
charDataConKey = mkPreludeDataConUnique 1
consDataConKey = mkPreludeDataConUnique 2
@@ -2097,7 +2105,6 @@ trueDataConKey = mkPreludeDataConUnique 14
wordDataConKey = mkPreludeDataConUnique 15
ioDataConKey = mkPreludeDataConUnique 16
heqDataConKey = mkPreludeDataConUnique 18
-nonEmptyDataConKey = mkPreludeDataConUnique 19
-- Generic data constructors
crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique
@@ -2115,7 +2122,10 @@ ordLTDataConKey = mkPreludeDataConUnique 27
ordEQDataConKey = mkPreludeDataConUnique 28
ordGTDataConKey = mkPreludeDataConUnique 29
+mkDictDataConKey :: Unique
+mkDictDataConKey = mkPreludeDataConUnique 30
+coercibleDataConKey :: Unique
coercibleDataConKey = mkPreludeDataConUnique 32
staticPtrDataConKey :: Unique
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -63,10 +63,6 @@ module GHC.Builtin.Types (
promotedNilDataCon, promotedConsDataCon,
mkListTy, mkPromotedListTy,
- -- * NonEmpty
- nonEmptyTyCon, nonEmptyTyConName,
- nonEmptyDataCon, nonEmptyDataConName,
-
-- * Maybe
maybeTyCon, maybeTyConName,
nothingDataCon, nothingDataConName, promotedNothingDataCon,
@@ -100,6 +96,9 @@ module GHC.Builtin.Types (
-- * Sums
mkSumTy, sumTyCon, sumDataCon,
+ -- * data type Dict
+ dictTyCon, mkDictDataCon,
+
-- * Kinds
typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName,
@@ -321,7 +320,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
, unliftedRepTyCon
, zeroBitRepTyCon
, zeroBitTypeTyCon
- , nonEmptyTyCon
+ , dictTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -380,10 +379,6 @@ listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List")
nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon
consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
-nonEmptyTyConName, nonEmptyDataConName :: Name
-nonEmptyTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey nonEmptyTyCon
-nonEmptyDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit ":|") nonEmptyDataConKey nonEmptyDataCon
-
maybeTyConName, nothingDataConName, justDataConName :: Name
maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe")
maybeTyConKey maybeTyCon
@@ -1188,6 +1183,23 @@ 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
@@ -1824,30 +1836,6 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
* *
********************************************************************* -}
-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 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 -}
-
-
charTy :: Type
charTy = mkTyConTy charTyCon
@@ -1924,6 +1912,35 @@ doubleTyCon = pcTyCon doubleTyConName
doubleDataCon :: DataCon
doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
+{- *********************************************************************
+* *
+ Boxing data constructors
+* *
+********************************************************************* -}
+
+{- 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) ]
+
{-
************************************************************************
* *
@@ -2038,17 +2055,6 @@ consDataCon = pcDataConWithFixity True {- Declared infix -}
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
-- gets the over-specific type (Type -> Type)
--- NonEmpty lists (used for 'ProjectionE')
-nonEmptyTyCon :: TyCon
-nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon]
-
-nonEmptyDataCon :: DataCon
-nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -}
- nonEmptyDataConName
- alpha_tyvar [] alpha_tyvar []
- (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])
- nonEmptyTyCon
-
-- Wired-in type Maybe
maybeTyCon :: TyCon
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -1,5 +1,3 @@
-
-
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Handy functions for creating much Core syntax
@@ -29,23 +27,18 @@ module GHC.Core.Make (
mkCoreTupBoxity, unitExpr,
-- * Constructing big tuples
- mkBigCoreVarTup, mkBigCoreVarTup1,
+ mkChunkified, chunkify,
+ mkBigCoreVarTup, mkBigCoreVarTupSolo,
mkBigCoreVarTupTy, mkBigCoreTupTy,
mkBigCoreTup,
- -- * Deconstructing small tuples
- mkSmallTupleSelector, mkSmallTupleCase,
-
- -- * Deconstructing big tuples
- mkTupleSelector, mkTupleSelector1, mkTupleCase,
+ -- * Deconstructing big tuples
+ mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase,
-- * Constructing list expressions
mkNilExpr, mkConsExpr, mkListExpr,
mkFoldrExpr, mkBuildExpr,
- -- * Constructing non empty lists
- mkNonEmptyListExpr,
-
-- * Constructing Maybe expressions
mkNothingExpr, mkJustExpr,
@@ -78,8 +71,6 @@ import GHC.Core.Coercion ( isCoVar )
import GHC.Core.DataCon ( DataCon, dataConWorkId )
import GHC.Core.Multiplicity
-import GHC.Hs.Utils ( mkChunkified, chunkify )
-
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
@@ -89,6 +80,7 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Settings.Constants( mAX_TUPLE_SIZE )
import GHC.Data.FastString
import Data.List ( partition )
@@ -334,20 +326,36 @@ mkStringExprFSWith ids str
{-
************************************************************************
* *
-\subsection{Tuple constructors}
+ Creating tuples and their types for Core expressions
* *
************************************************************************
-}
-{-
-Creating tuples and their types for Core expressions
+{- Note [Big tuples]
+~~~~~~~~~~~~~~~~~~~~
+GHCs built-in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
+we might conceivably want to build such a massive tuple as part of the
+output of a desugaring stage (notably that for list comprehensions).
+
+We call tuples above this size "big tuples", and emulate them by
+creating and pattern matching on >nested< tuples that are expressible
+by GHC.
+
+Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
+than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
+construction to be big.
- at mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector at .
+If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkBigTupleSelector'
+and 'mkBigTupleCase' functions to do all your work with tuples you should be
+fine, and not have to worry about the arity limitation at all.
+
+
+`mkBigCoreVarTup` builds a tuple; the inverse to `mkBigTupleSelector`.
* If it has only one element, it is the identity function.
* If there are more elements than a big tuple can have, it nests
- the tuples.
+ the tuples. See Note [Big tuples]
Note [Flattening one-tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -360,8 +368,8 @@ We could do one of two things:
mkCoreTup [e1] = e1
* Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types)
- mkCoreTup1 [e1] = Solo e1
- We use a suffix "1" to indicate this.
+ mkCoreTupSolo [e1] = Solo e1
+ We use a suffix "Solo" to indicate this.
Usually we want the former, but occasionally the latter.
@@ -390,14 +398,14 @@ mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup [c] = c
-mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform
+mkCoreTup cs = mkCoreTupSolo cs -- non-1-tuples are uniform
-- | Build a small tuple holding the specified expressions
-- One-tuples are *not* flattened; see Note [Flattening one-tuples]
-- See also Note [Don't flatten tuples from HsSyn]
-mkCoreTup1 :: [CoreExpr] -> CoreExpr
-mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs))
- (map (Type . exprType) cs ++ cs)
+mkCoreTupSolo :: [CoreExpr] -> CoreExpr
+mkCoreTupSolo cs = mkCoreConApps (tupleDataCon Boxed (length cs))
+ (map (Type . exprType) cs ++ cs)
-- | Build a small unboxed tuple holding the specified expressions,
-- with the given types. The types must be the types of the expressions.
@@ -412,7 +420,7 @@ mkCoreUbxTup tys exps
-- | Make a core tuple of the given boxity; don't flatten 1-tuples
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
-mkCoreTupBoxity Boxed exps = mkCoreTup1 exps
+mkCoreTupBoxity Boxed exps = mkCoreTupSolo exps
mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
-- | Build an unboxed sum.
@@ -427,37 +435,101 @@ mkCoreUbxSum arity alt tys exp
++ map Type tys
++ [exp])
+mkBigCoreVarTupSolo :: [Id] -> CoreExpr
+-- Same as mkBigCoreVarTup, but
+-- - one-tuples are not flattened
+-- see Note [Flattening one-tuples]
+-- - constraints are not wrapped -- they should never show up
+mkBigCoreVarTupSolo [id] = mkCoreConApps (tupleDataCon Boxed 1)
+ [Type (idType id), Var id]
+mkBigCoreVarTupSolo ids = mkChunkified mkCoreTup (map Var ids)
+
-- | Build a big tuple holding the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
+-- Constraints are wrapped in MkDict
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
-mkBigCoreVarTup1 :: [Id] -> CoreExpr
--- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
--- see Note [Flattening one-tuples]
-mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)
- [Type (idType id), Var id]
-mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids)
+-- | Build a "big" tuple holding the specified expressions
+-- One-tuples are flattened; see Note [Flattening one-tuples]
+-- Constraints are wrapped in MkDict
+mkBigCoreTup :: [CoreExpr] -> CoreExpr
+mkBigCoreTup exprs
+ = mkChunkified mkCoreTup (map wrapBox exprs)
-- | Build the type of a big tuple that holds the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
--- | Build a big tuple holding the specified expressions
--- One-tuples are flattened; see Note [Flattening one-tuples]
-mkBigCoreTup :: [CoreExpr] -> CoreExpr
-mkBigCoreTup = mkChunkified mkCoreTup
-
-- | Build the type of a big tuple that holds the specified type of thing
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkBigCoreTupTy :: [Type] -> Type
-mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
+mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $
+ map boxTy tys
-- | The unit expression
unitExpr :: CoreExpr
unitExpr = Var unitDataConId
+--------------------------------------------------------------
+wrapBox :: CoreExpr -> CoreExpr
+-- If (e :: ty) and (ty :: Type), wrapBox is a no-op
+-- 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
+ where
+ e_ty = exprType e
+
+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
+
+unwrapBox :: UniqSupply -> Id -> CoreExpr
+ -> (UniqSupply, Id, CoreExpr)
+-- (unwrapBox us v body)
+-- 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]
+
+
+-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition
+mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
+ -> [a] -- ^ Possible \"big\" list of things to construct from
+ -> a -- ^ Constructed thing made possible by recursive decomposition
+mkChunkified small_tuple as = mk_big_tuple (chunkify as)
+ where
+ -- Each sub-list is short enough to fit in a tuple
+ mk_big_tuple [as] = small_tuple as
+ mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
+
+chunkify :: [a] -> [[a]]
+-- ^ Split a list into lists that are small enough to have a corresponding
+-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
+-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
+chunkify xs
+ | n_xs <= mAX_TUPLE_SIZE = [xs]
+ | otherwise = split xs
+ where
+ n_xs = length xs
+ split [] = []
+ split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
+
+
{-
************************************************************************
* *
@@ -478,16 +550,16 @@ unitExpr = Var unitDataConId
-- If necessary, we pattern match on a \"big\" tuple.
--
-- A tuple selector is not linear in its argument. Consequently, the case
--- expression built by `mkTupleSelector` must consume its scrutinee 'Many'
+-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many'
-- times. And all the argument variables must have multiplicity 'Many'.
-mkTupleSelector, mkTupleSelector1
+mkBigTupleSelector, mkBigTupleSelectorSolo
:: [Id] -- ^ The 'Id's to pattern match the tuple against
-> Id -- ^ The 'Id' to select
-> Id -- ^ A variable of the same type as the scrutinee
-> CoreExpr -- ^ Scrutinee
-> CoreExpr -- ^ Selector expression
--- mkTupleSelector [a,b,c,d] b v e
+-- mkBigTupleSelector [a,b,c,d] b v e
-- = case e of v {
-- (p,q) -> case p of p {
-- (a,b) -> b }}
@@ -498,7 +570,7 @@ mkTupleSelector, mkTupleSelector1
-- case (case e of v
-- (p,q) -> p) of p
-- (a,b) -> b
-mkTupleSelector vars the_var scrut_var scrut
+mkBigTupleSelector vars the_var scrut_var scrut
= mk_tup_sel (chunkify vars) the_var
where
mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
@@ -507,18 +579,18 @@ mkTupleSelector vars the_var scrut_var scrut
where
tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
tpl_vs = mkTemplateLocals tpl_tys
- [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
+ [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s,
the_var `elem` gp ]
--- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
+-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
-mkTupleSelector1 vars the_var scrut_var scrut
+mkBigTupleSelectorSolo vars the_var scrut_var scrut
| [_] <- vars
= mkSmallTupleSelector1 vars the_var scrut_var scrut
| otherwise
- = mkTupleSelector vars the_var scrut_var scrut
+ = mkBigTupleSelector vars the_var scrut_var scrut
--- | Like 'mkTupleSelector' but for tuples that are guaranteed
--- never to be \"big\".
+-- | `mkSmallTupleSelector` is like 'mkBigTupleSelector', but for tuples that
+-- are guaranteed never to be "big". Also does not unwrap Dict types.
--
-- > mkSmallTupleSelector [x] x v e = [| e |]
-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
@@ -541,45 +613,71 @@ mkSmallTupleSelector1 vars the_var scrut_var scrut
Case scrut scrut_var (idType the_var)
[Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)]
--- | A generalization of 'mkTupleSelector', allowing the body
+-- | A generalization of 'mkBigTupleSelector', allowing the body
-- of the case to be an arbitrary expression.
--
-- To avoid shadowing, we use uniques to invent new variables.
--
--- If necessary we pattern match on a \"big\" tuple.
-mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
- -> [Id] -- ^ The tuple identifiers to pattern match on
- -> CoreExpr -- ^ Body of the case
- -> Id -- ^ A variable of the same type as the scrutinee
- -> CoreExpr -- ^ Scrutinee
- -> CoreExpr
+-- If necessary we pattern match on a "big" tuple.
+mkBigTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables
+ -> [Id] -- ^ The tuple identifiers to pattern match on;
+ -- Bring these into scope in the body
+ -> CoreExpr -- ^ Body of the case
+ -> CoreExpr -- ^ Scrutinee
+ -> CoreExpr
-- ToDo: eliminate cases where none of the variables are needed.
--
--- mkTupleCase uniqs [a,b,c,d] body v e
+-- mkBigTupleCase uniqs [a,b,c,d] body v e
-- = case e of v { (p,q) ->
-- case p of p { (a,b) ->
-- case q of q { (c,d) ->
-- body }}}
-mkTupleCase uniqs vars body scrut_var scrut
- = mk_tuple_case uniqs (chunkify vars) body
+mkBigTupleCase us vars body scrut
+ = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body
where
+ (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars
+
+ scrut_ty = exprType scrut
+
+ unwrap var (us,vars,body)
+ = (us', var':vars, body')
+ where
+ (us', var', body') = unwrapBox us var body
+
+ mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
+ -- mk_tuple_case [[a1..an], [b1..bm], ...] body
+ -- case scrut of (p,q, ...) ->
+ -- case p of (a1,..an) ->
+ -- case q of (b1,..bm) ->
+ -- ... -> body
-- This is the case where don't need any nesting
- mk_tuple_case _ [vars] body
+ mk_tuple_case us [vars] body
= mkSmallTupleCase vars body scrut_var scrut
+ where
+ scrut_var = case scrut of
+ Var v -> v
+ _ -> snd (new_var us scrut_ty)
- -- This is the case where we must make nest tuples at least once
+ -- This is the case where we must nest tuples at least once
mk_tuple_case us vars_s body
- = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
- in mk_tuple_case us' (chunkify vars') body'
+ = mk_tuple_case us' (chunkify vars') body'
+ where
+ (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
one_tuple_case chunk_vars (us, vs, body)
- = let (uniq, us') = takeUniqFromSupply us
- scrut_var = mkSysLocal (fsLit "ds") uniq ManyTy
- (mkBoxedTupleTy (map idType chunk_vars))
- body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
- in (us', scrut_var:vs, body')
-
--- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
+ = (us', scrut_var:vs, body')
+ where
+ tup_ty = mkBoxedTupleTy (map idType chunk_vars)
+ (us', scrut_var) = new_var us tup_ty
+ body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
+
+ new_var :: UniqSupply -> Type -> (UniqSupply, Id)
+ new_var us ty = (us', id)
+ where
+ (uniq, us') = takeUniqFromSupply us
+ id = mkSysLocal (fsLit "ds") uniq ManyTy ty
+
+-- | As 'mkBigTupleCase', but for a tuple that is small enough to be guaranteed
-- not to need nesting.
mkSmallTupleCase
:: [Id] -- ^ The tuple args
@@ -591,7 +689,6 @@ mkSmallTupleCase
mkSmallTupleCase [var] body _scrut_var scrut
= bindNonRec var scrut body
mkSmallTupleCase vars body scrut_var scrut
--- One branch no refinement?
= Case scrut scrut_var (exprType body)
[Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body]
@@ -654,9 +751,6 @@ mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
-mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkNonEmptyListExpr ty x xs = mkCoreConApps nonEmptyDataCon [Type ty, x, mkListExpr ty xs]
-
-- | Make a fully applied 'foldr' expression
mkFoldrExpr :: MonadThings m
=> Type -- ^ Element type of the list
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2652,6 +2652,7 @@ typeTypeOrConstraint ty
isPredTy :: HasDebugCallStack => Type -> Bool
-- Precondition: expects a type that classifies values
-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep
+-- Returns True for types of kind Constraint, False for ones of kind Type
isPredTy ty = case typeTypeOrConstraint ty of
TypeLike -> False
ConstraintLike -> True
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -55,10 +55,6 @@ module GHC.Hs.Utils(
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
mkLocatedList,
- -- * Constructing general big tuples
- -- $big_tuples
- mkChunkified, chunkify,
-
-- * Bindings
mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
mkPatSynBind,
@@ -127,7 +123,8 @@ import GHC.Core.Coercion( isReflCo )
import GHC.Core.Multiplicity ( pattern ManyTy )
import GHC.Core.DataCon
import GHC.Core.ConLike
-import GHC.Core.Type( Type, isUnliftedType )
+import GHC.Core.Make ( mkChunkified )
+import GHC.Core.Type ( Type, isUnliftedType )
import GHC.Builtin.Types ( unitTy )
@@ -144,7 +141,6 @@ import GHC.Types.SourceText
import GHC.Data.FastString
import GHC.Data.Bag
-import GHC.Settings.Constants
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -678,47 +674,6 @@ mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkBigLHsPatTup = mkChunkified mkLHsPatTup
--- $big_tuples
--- #big_tuples#
---
--- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
--- we might conceivably want to build such a massive tuple as part of the
--- output of a desugaring stage (notably that for list comprehensions).
---
--- We call tuples above this size \"big tuples\", and emulate them by
--- creating and pattern matching on >nested< tuples that are expressible
--- by GHC.
---
--- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
--- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
--- construction to be big.
---
--- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
--- and 'mkTupleCase' functions to do all your work with tuples you should be
--- fine, and not have to worry about the arity limitation at all.
-
--- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition
-mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
- -> [a] -- ^ Possible \"big\" list of things to construct from
- -> a -- ^ Constructed thing made possible by recursive decomposition
-mkChunkified small_tuple as = mk_big_tuple (chunkify as)
- where
- -- Each sub-list is short enough to fit in a tuple
- mk_big_tuple [as] = small_tuple as
- mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
-
-chunkify :: [a] -> [[a]]
--- ^ Split a list into lists that are small enough to have a corresponding
--- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
--- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
-chunkify xs
- | n_xs <= mAX_TUPLE_SIZE = [xs]
- | otherwise = split xs
- where
- n_xs = length xs
- split [] = []
- split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
-
{-
************************************************************************
* *
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -162,7 +162,7 @@ because the list of variables is typically not yet defined.
coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
coreCaseTuple uniqs scrut_var vars body
- = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
+ = mkBigTupleCase uniqs vars body (Var scrut_var)
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
@@ -178,10 +178,19 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
mkCoreUnitExpr :: CoreExpr
mkCoreUnitExpr = mkCoreTup []
-{-
-The input is divided into a local environment, which is a flat tuple
-(unless it's too big), and a stack, which is a right-nested pair.
-In general, the input has the form
+{- Note [Environment and stack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The input is divided into
+
+* A local environment, which is a flat tuple (unless it's too big)
+ The elements of the local environment can be
+ - of kind Type (for ordinary variables), or
+ - of kind Constraint (for dictionaries bound by patterns)
+
+* A stack, which is a right-nested pair.
+ The elements on the stack are always of kind Type.
+
+So in general, the input has the form
((x1,...,xn), (s1,...(sk,())...))
@@ -1120,7 +1129,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
where
selectVar v
| v `elemVarSet` rec_id_set
- = mkTupleSelector rec_ids v rec_id (Var rec_id)
+ = mkBigTupleSelector rec_ids v rec_id (Var rec_id)
| otherwise = Var v
squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -314,7 +314,7 @@ dsAbsBinds dflags tyvars dicts exports
= do { tup_id <- newSysLocalDs ManyTy tup_ty
; core_wrap <- dsHsWrapper wrap
; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
- mkTupleSelector all_locals local tup_id $
+ mkBigTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -450,8 +450,8 @@ mkUnzipBind _ elt_tys
concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
tupled_concat_expression = mkBigCoreTup concat_expressions
- folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
- folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+ folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs)
+ folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax)
folder_body = mkLams [ax, axs] folder_body_outer_case
; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
@@ -543,15 +543,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
-- Generate the expressions to build the grouped list
-- Build a pattern that ensures the consumer binds into the NEW binders,
-- which hold monads rather than single values
- ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
-
; body <- dsMcStmts stmts_rest
; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty'
- ; tup_n_var' <- newSysLocalDs ManyTy tup_n_ty'
; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
; us <- newUniqueSupply
; let rhs' = mkApps usingExpr' usingArgs'
- body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
+ body' = mkBigTupleCase us to_bndrs body tup_n_expr'
; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
@@ -597,7 +594,7 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
matchTuple ids body
= do { us <- newUniqueSupply
; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids)
- ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+ ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) }
-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
-- desugared `CoreExpr`
@@ -660,6 +657,6 @@ mkMcUnzipM _ fmap_op ys elt_tys
, mk_sel i, Var ys]
mk_sel n = Lam tup_xs $
- mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
+ mkBigTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -2963,7 +2963,9 @@ repGetField (MkC exp) fs = do
repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp))
repProjection fs = do
- MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs
+ ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName
+ MkC xs <- coreListNonEmpty ne_tycon stringTy <$>
+ mapM (coreStringLit . unpackFS) fs
rep2 projectionEName [xs]
------------ Lists -------------------
@@ -2995,8 +2997,13 @@ coreList' :: Type -- The element type
-> [Core a] -> Core [a]
coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
-coreListNonEmpty :: Type -> NonEmpty (Core a) -> Core (NonEmpty a)
-coreListNonEmpty ty (MkC x :| xs) = MkC $ mkNonEmptyListExpr ty x (map unC xs)
+coreListNonEmpty :: TyCon -- TyCon for NonEmpty
+ -> Type -- Element type
+ -> NonEmpty (Core a)
+ -> Core (NonEmpty a)
+coreListNonEmpty ne_tc ty (MkC x :| xs)
+ = MkC $ mkCoreConApps (tyConSingleDataCon ne_tc)
+ [Type ty, x, mkListExpr ty (map unC xs)]
nonEmptyCoreList :: [Core a] -> Core [a]
-- The list must be non-empty so we can get the element type
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -629,7 +629,7 @@ There are two cases.
Note that we return 't' as the variable to force if the pattern
is strict (i.e. with -XStrict or an outermost-bang-pattern)
- Note that (A) /includes/ the situation where
+ Note that (C) /includes/ the situation where
* The pattern binds exactly one variable
let !(Just (Just x) = e in body
@@ -639,7 +639,8 @@ There are two cases.
in t `seq` body
The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types
Note that forcing 't' makes the pattern match happen,
- but does not force 'v'.
+ but does not force 'v'. That's why we call `mkBigCoreVarTupSolo`
+ in `mkSeletcorBinds`
* The pattern binds no variables
let !(True,False) = e in body
@@ -761,7 +762,7 @@ mkSelectorBinds ticks pat val_expr
local_tuple error_expr
; let mk_tup_bind tick binder
= (binder, mkOptTickBox tick $
- mkTupleSelector1 local_binders binder
+ mkBigTupleSelectorSolo local_binders binder
tuple_var (Var tuple_var))
tup_binds = zipWith mk_tup_bind ticks' binders
; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
@@ -774,7 +775,7 @@ mkSelectorBinds ticks pat val_expr
ticks' = ticks ++ repeat []
local_binders = map localiseId binders -- See Note [Localise pattern binders]
- local_tuple = mkBigCoreVarTup1 binders
+ local_tuple = mkBigCoreVarTupSolo binders
tuple_ty = exprType local_tuple
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -381,7 +381,7 @@ getSymtabName _name_cache _dict symtab bh = do
in
return $! case lookupKnownKeyName u of
Nothing -> pprPanic "getSymtabName:unknown known-key unique"
- (ppr i $$ ppr u)
+ (ppr i $$ ppr u $$ char tag $$ ppr ix)
Just n -> n
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
=====================================
libraries/ghc-prim/GHC/Magic/Dict.hs
=====================================
@@ -29,7 +29,9 @@
--
-----------------------------------------------------------------------------
-module GHC.Magic.Dict (WithDict(..)) where
+module GHC.Magic.Dict (
+ WithDict( withDict )
+ ) where
import GHC.Types (RuntimeRep, TYPE)
@@ -57,4 +59,4 @@ there is nothing that forces the `cls` Wanted from the call to `k` to unify with
That's fine. But it means we need -XAllowAmbiguousTypes for the withDict definition,
at least with deep subsumption.
--}
\ No newline at end of file
+-}
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples,
MultiParamTypeClasses, RoleAnnotations, CPP, TypeOperators,
PolyKinds, NegativeLiterals, DataKinds, ScopedTypeVariables,
- TypeApplications, StandaloneKindSignatures,
+ TypeApplications, StandaloneKindSignatures, GADTs,
FlexibleInstances, UndecidableInstances #-}
-- NegativeLiterals: see Note [Fixity of (->)]
{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-}
@@ -51,6 +51,11 @@ module GHC.Types (
VecCount(..), VecElem(..),
Void#,
+ -- * Boxing constructors
+ DictBox( MkDictBox ),
+ WordBox( MkWordBox), IntBox( MkIntBox),
+ FloatBox( MkFloatBox), DoubleBox( MkDoubleBox),
+
-- * Multiplicity types
Multiplicity(..), MultMul,
@@ -501,6 +506,24 @@ data VecElem = Int8ElemRep
{-# DEPRECATED Void# "Void# is now an alias for the unboxed tuple (# #)." #-}
type Void# = (# #)
+{- *********************************************************************
+* *
+ Boxing data constructors
+* *
+********************************************************************* -}
+
+-- 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 type `Dict` provides a simple way to wrap up constraint as a type
+data DictBox c where
+ MkDictBox :: c => DictBox c
+
+
{- *********************************************************************
* *
Runtime representation of TyCon
=====================================
testsuite/tests/ghci.debugger/scripts/break013.stdout
=====================================
@@ -3,7 +3,7 @@ _result :: (Bool, Bool, ()) = _
a :: Bool = _
b :: Bool = _
c :: () = _
-c :: () = _
b :: Bool = _
a :: Bool = _
+c :: () = _
_result :: (Bool, Bool, ()) = _
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05f5d5f313c33d58063e95183bc722c8a0052411
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05f5d5f313c33d58063e95183bc722c8a0052411
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/20220911/eaeb1342/attachment-0001.html>
More information about the ghc-commits
mailing list