diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-06-15 19:58:10 +0200 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-06-17 16:21:58 -0400 |
| commit | 40fa237e1daab7a76b9871bb6c50b953a1addf23 (patch) | |
| tree | 79751e932434be440ba35b4d65c54f25a437e134 | |
| parent | 20616959a7f4821034e14a64c3c9bf288c9bc956 (diff) | |
| download | haskell-40fa237e1daab7a76b9871bb6c50b953a1addf23.tar.gz | |
Linear types (#15981)
This is the first step towards implementation of the linear types proposal
(https://github.com/ghc-proposals/ghc-proposals/pull/111).
It features
* A language extension -XLinearTypes
* Syntax for linear functions in the surface language
* Linearity checking in Core Lint, enabled with -dlinear-core-lint
* Core-to-core passes are mostly compatible with linearity
* Fields in a data type can be linear or unrestricted; linear fields
have multiplicity-polymorphic constructors.
If -XLinearTypes is disabled, the GADT syntax defaults to linear fields
The following items are not yet supported:
* a # m -> b syntax (only prefix FUN is supported for now)
* Full multiplicity inference (multiplicities are really only checked)
* Decent linearity error messages
* Linear let, where, and case expressions in the surface language
(each of these currently introduce the unrestricted variant)
* Multiplicity-parametric fields
* Syntax for annotating lambda-bound or let-bound with a multiplicity
* Syntax for non-linear/multiple-field-multiplicity records
* Linear projections for records with a single linear field
* Linear pattern synonyms
* Multiplicity coercions (test LinearPolyType)
A high-level description can be found at
https://ghc.haskell.org/trac/ghc/wiki/LinearTypes/Implementation
Following the link above you will find a description of the changes made to Core.
This commit has been authored by
* Richard Eisenberg
* Krzysztof Gogolewski
* Matthew Pickering
* Arnaud Spiwack
With contributions from:
* Mark Barbone
* Alexander Vershilov
Updates haddock submodule.
323 files changed, 6039 insertions, 1997 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index b619f0c14c..c7527d2b22 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -197,7 +197,7 @@ module GHC ( -- ** Data constructors DataCon, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, + dataConIsInfix, isVanillaDataCon, dataConWrapperType, dataConSrcBangs, StrictnessMark(..), isMarkedStrict, diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 5b787ea0c7..3494c4a2d2 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -1901,6 +1901,15 @@ typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190 unsafeEqualityTyConKey :: Unique unsafeEqualityTyConKey = mkPreludeTyConUnique 191 +-- Linear types +multiplicityTyConKey :: Unique +multiplicityTyConKey = mkPreludeTyConUnique 192 + +unrestrictedFunTyConKey :: Unique +unrestrictedFunTyConKey = mkPreludeTyConUnique 193 + +multMulTyConKey :: Unique +multMulTyConKey = mkPreludeTyConUnique 194 ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES TyConUniques 200-299 @@ -2075,6 +2084,12 @@ typeLitNatDataConKey = mkPreludeDataConUnique 113 unsafeReflDataConKey :: Unique unsafeReflDataConKey = mkPreludeDataConUnique 114 +-- Multiplicity + +oneDataConKey, manyDataConKey :: Unique +oneDataConKey = mkPreludeDataConUnique 115 +manyDataConKey = mkPreludeDataConUnique 116 + ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES DataUniques 200-250 ----------------------------------------------------- diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 4dd1b43e83..dcee4259f0 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -98,7 +98,7 @@ templateHaskellNames = [ -- Type forallTName, forallVisTName, varTName, conTName, infixTName, appTName, appKindTName, equalityTName, tupleTName, unboxedTupleTName, - unboxedSumTName, arrowTName, listTName, sigTName, litTName, + unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName, -- TyLit @@ -438,8 +438,8 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey -- data Type = ... forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName, - unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName, - appKindTName, sigTName, equalityTName, litTName, promotedTName, + unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName, + appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey @@ -450,6 +450,7 @@ tupleTName = libFun (fsLit "tupleT") tupleTIdKey unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey arrowTName = libFun (fsLit "arrowT") arrowTIdKey +mulArrowTName = libFun (fsLit "mulArrowT") mulArrowTIdKey listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey appKindTName = libFun (fsLit "appKindT") appKindTIdKey @@ -1046,6 +1047,10 @@ interruptibleIdKey = mkPreludeMiscIdUnique 442 funDepIdKey :: Unique funDepIdKey = mkPreludeMiscIdUnique 445 +-- mulArrow +mulArrowTIdKey :: Unique +mulArrowTIdKey = mkPreludeMiscIdUnique 446 + -- data TySynEqn = ... tySynEqnIdKey :: Unique tySynEqnIdKey = mkPreludeMiscIdUnique 460 diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 96d5a5ad0d..86c3894f06 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -579,7 +579,7 @@ primOpType op Compare _occ ty -> compare_fun_ty ty GenPrimOp _occ tyvars arg_tys res_ty -> - mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) + mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) primOpOcc :: PrimOp -> OccName primOpOcc op = case primOpInfo op of @@ -739,9 +739,9 @@ commutableOp :: PrimOp -> Bool -- Utils: dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type -dyadic_fun_ty ty = mkVisFunTys [ty, ty] ty -monadic_fun_ty ty = mkVisFunTy ty ty -compare_fun_ty ty = mkVisFunTys [ty, ty] intPrimTy +dyadic_fun_ty ty = mkVisFunTysMany [ty, ty] ty +monadic_fun_ty ty = mkVisFunTyMany ty ty +compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy -- Output stuff: diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index eed9420aa6..37d47e735d 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -125,7 +125,17 @@ module GHC.Builtin.Types ( int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy + + doubleElemRepDataConTy, + + -- * Multiplicity and friends + multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy, + multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy, + oneDataConTyCon, manyDataConTyCon, + multMulTyCon, + + unrestrictedFunTyCon, unrestrictedFunTyConName + ) where #include "HsVersions.h" @@ -142,6 +152,7 @@ import {-# SOURCE #-} GHC.Builtin.Uniques -- others: import GHC.Core.Coercion.Axiom import GHC.Types.Id +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 @@ -150,6 +161,7 @@ import GHC.Core.DataCon import {-# SOURCE #-} GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Class ( Class, mkClass ) +import GHC.Core.Multiplicity import GHC.Types.Name.Reader import GHC.Types.Name as Name import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) @@ -240,6 +252,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , vecElemTyCon , constraintKindTyCon , liftedTypeKindTyCon + , multiplicityTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -461,6 +474,20 @@ constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constr liftedTypeKindTyConName :: Name liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon +multiplicityTyConName :: Name +multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") + multiplicityTyConKey multiplicityTyCon + +oneDataConName, manyDataConName :: Name +oneDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon +manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon + -- It feels wrong to have One and Many be BuiltInSyntax. But otherwise, + -- `Many`, in particular, is considered out of scope unless an appropriate + -- file is open. The problem with this is that `Many` appears implicitly in + -- types every time there is an `(->)`, hence out-of-scope errors get + -- reported. Making them built-in make it so that they are always considered in + -- scope. + runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon @@ -544,16 +571,20 @@ pcTyCon name cType tyvars cons False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon n univs = pcDataConWithFixity False n univs +pcDataCon n univs tys = pcDataConW n univs (map linear tys) + +pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon +pcDataConW n univs tys = pcDataConWithFixity False n univs [] -- no ex_tvs univs -- the univs are precisely the user-written tyvars + tys pcDataConWithFixity :: Bool -- ^ declared infix? -> Name -- ^ datacon name -> [TyVar] -- ^ univ tyvars -> [TyCoVar] -- ^ ex tycovars -> [TyCoVar] -- ^ user-written tycovars - -> [Type] -- ^ args + -> [Scaled Type] -- ^ args -> TyCon -> DataCon pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) @@ -567,7 +598,7 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo -> [TyVar] -> [TyCoVar] -> [TyCoVar] - -> [Type] -> TyCon -> DataCon + -> [Scaled Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. -- @@ -625,7 +656,7 @@ mkDataConWorkerName data_con wrk_key = pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon pcSpecialDataCon dc_name arg_tys tycon rri = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri - [] [] [] arg_tys tycon + [] [] [] (map linear arg_tys) tycon {- ************************************************************************ @@ -651,7 +682,7 @@ constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] liftedTypeKind, typeToTypeKind, constraintKind :: Kind liftedTypeKind = tYPE liftedRepTy -typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind +typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind constraintKind = mkTyConApp constraintKindTyCon [] {- @@ -791,7 +822,8 @@ isBuiltInOcc_maybe occ = "~" -> Just eqTyConName -- function tycon - "->" -> Just funTyConName + "FUN" -> Just funTyConName + "->" -> Just unrestrictedFunTyConName -- boxed tuple data/tycon -- We deliberately exclude Solo (the boxed 1-tuple). @@ -1149,7 +1181,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id rhs klass (mkPrelTyConRepName eqTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon eqDataConName tvs [sc_pred] tycon + datacon = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) @@ -1167,7 +1199,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id rhs klass (mkPrelTyConRepName heqTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon heqDataConName tvs [sc_pred] tycon + datacon = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon -- Kind: forall k1 k2. k1 -> k2 -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id @@ -1185,7 +1217,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id rhs klass (mkPrelTyConRepName coercibleTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon + datacon = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) @@ -1205,6 +1237,67 @@ mk_class tycon sc_pred sc_sel_id {- ********************************************************************* * * + Multiplicity Polymorphism +* * +********************************************************************* -} + +{- Multiplicity polymorphism is implemented very similarly to levity + polymorphism. We write in the multiplicity kind and the One and Many + types which can appear in user programs. These are defined properly in GHC.Types. + +data Multiplicity = One | Many +-} + +multiplicityTy :: Type +multiplicityTy = mkTyConTy multiplicityTyCon + +multiplicityTyCon :: TyCon +multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] + [oneDataCon, manyDataCon] + +oneDataCon, manyDataCon :: DataCon +oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon +manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon + +oneDataConTy, manyDataConTy :: Type +oneDataConTy = mkTyConTy oneDataConTyCon +manyDataConTy = mkTyConTy manyDataConTyCon + +oneDataConTyCon, manyDataConTyCon :: TyCon +oneDataConTyCon = promoteDataCon oneDataCon +manyDataConTyCon = promoteDataCon manyDataCon + +multMulTyConName :: Name +multMulTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon + +multMulTyCon :: TyCon +multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing + (BuiltInSynFamTyCon trivialBuiltInFamily) + Nothing + NotInjective + where + binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] + +unrestrictedFunTy :: Type +unrestrictedFunTy = functionWithMultiplicity manyDataConTy + +unrestrictedFunTyCon :: TyCon +unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy + where arrowKind = mkTyConKind binders liftedTypeKind + -- See also funTyCon + binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) + , Bndr runtimeRep2TyVar (NamedTCB Inferred) + ] + ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty + , tYPE runtimeRep2Ty + ] + +unrestrictedFunTyConName :: Name +unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") unrestrictedFunTyConKey unrestrictedFunTyCon + +{- ********************************************************************* +* * Kinds and RuntimeRep * * ********************************************************************* -} @@ -1576,7 +1669,7 @@ consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -} consDataConName alpha_tyvar [] alpha_tyvar - [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon + (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index b575fd2de3..db14a844d1 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -44,4 +44,13 @@ anyTypeOfKind :: Kind -> Type unboxedTupleKind :: [Type] -> Type mkPromotedListTy :: Type -> [Type] -> Type +multiplicityTyCon :: TyCon +multiplicityTy :: Type +oneDataConTy :: Type +oneDataConTyCon :: TyCon +manyDataConTy :: Type +manyDataConTyCon :: TyCon +unrestrictedFunTyCon :: TyCon +multMulTyCon :: TyCon + tupleTyConName :: TupleSort -> Arity -> Name diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index ecf166e402..bc319fca74 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -26,12 +26,16 @@ module GHC.Builtin.Types.Prim( runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, + multiplicityTyVar, + multiplicityTyVarList, + -- Kind constructors... tYPETyCon, tYPETyConName, -- Kinds tYPE, primRepToRuntimeRep, + functionWithMultiplicity, funTyCon, funTyConName, unexposedPrimTyCons, exposedPrimTyCons, primTyCons, @@ -108,7 +112,7 @@ import {-# SOURCE #-} GHC.Builtin.Types , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy , doubleElemRepDataConTy - , mkPromotedListTy ) + , mkPromotedListTy, multiplicityTy ) import GHC.Types.Var ( TyVar, mkTyVar ) import GHC.Types.Name @@ -385,6 +389,14 @@ openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar +multiplicityTyVar :: TyVar +multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13 -- selects 'n' + +-- Create 'count' multiplicity TyVars +multiplicityTyVarList :: Int -> [TyVar] +multiplicityTyVarList count = take count $ + drop 13 $ -- selects 'n', 'o'... + mkTemplateTyVars (repeat multiplicityTy) {- ************************************************************************ * * @@ -394,13 +406,13 @@ openBetaTy = mkTyVarTy openBetaTyVar -} funTyConName :: Name -funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon +funTyConName = mkPrimTyConName (fsLit "FUN") funTyConKey funTyCon --- | The @(->)@ type constructor. +-- | The @FUN@ type constructor. -- -- @ --- (->) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. --- TYPE rep1 -> TYPE rep2 -> Type +-- FUN :: forall {m :: Multiplicity} {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- TYPE rep1 -> TYPE rep2 -> * -- @ -- -- The runtime representations quantification is left inferred. This @@ -413,13 +425,15 @@ funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon -- @ -- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). -- TYPE rep1 -> TYPE rep2 -> Type --- type Arr = (->) +-- type Arr = FUN -- @ -- funTyCon :: TyCon funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm where - tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar + , mkNamedTyConBinder Inferred runtimeRep1TyVar , mkNamedTyConBinder Inferred runtimeRep2TyVar ] ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty , tYPE runtimeRep2Ty @@ -543,6 +557,10 @@ mkPrimTcName built_in_syntax occ key tycon tYPE :: Type -> Type tYPE rr = TyConApp tYPETyCon [rr] +-- Given a Multiplicity, applies FUN to it. +functionWithMultiplicity :: Type -> Type +functionWithMultiplicity mul = TyConApp funTyCon [mul] + {- ************************************************************************ * * diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index ee7bdac29a..a9ebb5645f 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -194,17 +194,15 @@ section "The word size story." -- This type won't be exported directly (since there is no concrete -- syntax for this sort of export) so we'll have to manually patch -- export lists in both GHC and Haddock. -primtype (->) a b - {The builtin function type, written in infix form as {\tt a -> b} and - in prefix form as {\tt (->) a b}. Values of this type are functions - taking inputs of type {\tt a} and producing outputs of type {\tt b}. +primtype FUN m a b + {The builtin function type, written in infix form as {\tt a # m -> b}. + Values of this type are functions taking inputs of type {\tt a} and + producing outputs of type {\tt b}. The multiplicity of the input is + {\tt m}. - Note that {\tt a -> b} permits levity-polymorphism in both {\tt a} and + Note that {\tt FUN m a b} permits levity-polymorphism in both {\tt a} and {\tt b}, so that types like {\tt Int\# -> Int\#} can still be well-kinded. } - with fixity = infixr -1 - -- This fixity is only the one picked up by Haddock. If you - -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'. ------------------------------------------------------------------------ section "Char#" diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index 73f55f63cc..b02683d10f 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -19,6 +19,7 @@ import GHC.Types.Name ( Name, getName ) import GHC.Types.Name.Env import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import GHC.Core.Multiplicity ( scaledThing ) import GHC.Types.RepType import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) @@ -58,7 +59,7 @@ make_constr_itbls hsc_env cons = mk_itbl dcon conNo = do let rep_args = [ NonVoid prim_rep | arg <- dataConRepArgTys dcon - , prim_rep <- typePrimRep arg ] + , prim_rep <- typePrimRep (scaledThing arg) ] (tot_wds, ptr_wds) = mkVirtConstrSizes dflags rep_args diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index ee19d87ff4..5653a71af2 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -518,6 +518,10 @@ checked by Core Lint. 7. The type of the scrutinee must be the same as the type of the case binder, obviously. Checked in lintCaseExpr. +8. The multiplicity of the binders in constructor patterns must be the + multiplicity of the corresponding field /scaled by the multiplicity of the + case binder/. Checked in lintCoreAlt. + Note [Core type and coercion invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow a /non-recursive/, /non-top-level/ let to bind type and diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index e89709929b..6b28adf371 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -112,6 +112,8 @@ module GHC.Core.Coercion ( -- * Other promoteCoercion, buildCoercion, + multToCo, + simplifyArgsWorker, badCoercionHole, badCoercionHoleCo @@ -147,6 +149,7 @@ import GHC.Builtin.Types.Prim import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM +import GHC.Core.Multiplicity import Control.Monad (foldM, zipWithM) import Data.Function ( on ) @@ -298,9 +301,9 @@ whose `RuntimeRep' arguments are intentionally marked inferred to avoid type application. Hence - FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) + FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2) is short for - TyConAppCo (->) co_rep1 co_rep2 co1 co2 + TyConAppCo (->) mult co_rep1 co_rep2 co1 co2 where co_rep1, co_rep2 are the coercions on the representations. -} @@ -321,12 +324,12 @@ decomposeCo arity co rs decomposeFunCo :: HasDebugCallStack => Role -- Role of the input coercion -> Coercion -- Input coercion - -> (Coercion, Coercion) + -> (CoercionN, Coercion, Coercion) -- Expects co :: (s1 -> t1) ~ (s2 -> t2) -- Returns (co1 :: s1~s2, co2 :: t1~t2) --- See Note [Function coercions] for the "2" and "3" +-- See Note [Function coercions] for the "3" and "4" decomposeFunCo r co = ASSERT2( all_ok, ppr co ) - (mkNthCo r 2 co, mkNthCo r 3 co) + (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co) where Pair s1t1 s2t2 = coercionKind co all_ok = isFunTy s1t1 && isFunTy s2t2 @@ -401,7 +404,9 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args -- ty :: s2 -- need arg_co :: s2 ~ s1 -- res_co :: t1 ~ t2 - = let (sym_arg_co, res_co) = decomposeFunCo Nominal co + = let (_, sym_arg_co, res_co) = decomposeFunCo Nominal co + -- It should be fine to ignore the multiplicity bit of the coercion + -- for a Nominal coercion. arg_co = mkSymCo sym_arg_co in go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys @@ -430,10 +435,13 @@ splitTyConAppCo_maybe co ; let args = zipWith mkReflCo (tyConRolesX r tc) tys ; return (tc, args) } splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) -splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) - where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] +splitTyConAppCo_maybe (FunCo _ w arg res) = Just (funTyCon, cos) + where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] splitTyConAppCo_maybe _ = Nothing +multToCo :: Mult -> Coercion +multToCo r = mkNomReflCo r + -- first result has role equal to input; third result is Nominal splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -- ^ Attempt to take a coercion application apart. @@ -457,8 +465,9 @@ splitAppCo_maybe co = Just (mkReflCo r ty1, mkNomReflCo ty2) splitAppCo_maybe _ = Nothing +-- Only used in specialise/Rules splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) +splitFunCo_maybe (FunCo _ _ arg res) = Just (arg, res) splitFunCo_maybe _ = Nothing splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) @@ -682,12 +691,12 @@ mkNomReflCo = Refl -- caller's responsibility to get the roles correct on argument coercions. mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos - | tc `hasKey` funTyConKey - , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] + | [w, _rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] + , isFunTyCon tc = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) -- rep1 :: ra ~ rc rep2 :: rb ~ rd -- co1 :: a ~ c co2 :: b ~ d - mkFunCo r co1 co2 + mkFunCo r w co1 co2 -- Expand type synonyms | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos @@ -701,13 +710,14 @@ mkTyConAppCo r tc cos -- | Build a function 'Coercion' from two other 'Coercion's. That is, -- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. -mkFunCo :: Role -> Coercion -> Coercion -> Coercion -mkFunCo r co1 co2 +mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo r w co1 co2 -- See Note [Refl invariant] | Just (ty1, _) <- isReflCo_maybe co1 , Just (ty2, _) <- isReflCo_maybe co2 - = mkReflCo r (mkVisFunTy ty1 ty2) - | otherwise = FunCo r co1 co2 + , Just (w, _) <- isReflCo_maybe w + = mkReflCo r (mkVisFunTy w ty1 ty2) + | otherwise = FunCo r w co1 co2 -- | Apply a 'Coercion' to another 'Coercion'. -- The second coercion must be Nominal, unless the first is Phantom. @@ -810,7 +820,8 @@ mkForAllCo_NoRefl v kind_co co , ASSERT( not (isReflCo co)) True , isCoVar v , not (v `elemVarSet` tyCoVarsOfCo co) - = FunCo (coercionRole co) kind_co co + = FunCo (coercionRole co) (multToCo Many) kind_co co + -- Functions from coercions are always unrestricted | otherwise = ForAllCo v kind_co co @@ -1024,21 +1035,22 @@ mkNthCo r n co -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) - go r n co@(FunCo r0 arg res) + go r n co@(FunCo r0 w arg res) -- See Note [Function coercions] - -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) - -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) + -- If FunCo _ mult arg_co res_co :: (s1:TYPE sk1 :mult-> s2:TYPE sk2) + -- ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2) -- Then we want to behave as if co was - -- TyConAppCo argk_co resk_co arg_co res_co + -- TyConAppCo mult argk_co resk_co arg_co res_co -- where -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) -- i.e. mkRuntimeRepCo = case n of - 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg - 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res - 2 -> ASSERT( r == r0 ) arg - 3 -> ASSERT( r == r0 ) res + 0 -> ASSERT( r == Nominal ) w + 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg + 2 -> ASSERT( r == Nominal ) mkRuntimeRepCo res + 3 -> ASSERT( r == r0 ) arg + 4 -> ASSERT( r == r0 ) res _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n @@ -1186,8 +1198,8 @@ mkSubCo (Refl ty) = GRefl Representational ty MRefl mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co mkSubCo (TyConAppCo Nominal tc cos) = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (FunCo Nominal arg res) - = FunCo Representational +mkSubCo (FunCo Nominal w arg res) + = FunCo Representational w (downgradeRole Representational Nominal arg) (downgradeRole Representational Nominal res) mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) @@ -1259,10 +1271,10 @@ setNominalRole_maybe r co setNominalRole_maybe_helper (TyConAppCo Representational tc cos) = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos ; return $ TyConAppCo Nominal tc cos' } - setNominalRole_maybe_helper (FunCo Representational co1 co2) + setNominalRole_maybe_helper (FunCo Representational w co1 co2) = do { co1' <- setNominalRole_maybe Representational co1 ; co2' <- setNominalRole_maybe Representational co2 - ; return $ FunCo Nominal co1' co2' + ; return $ FunCo Nominal w co1' co2' } setNominalRole_maybe_helper (SymCo co) = SymCo <$> setNominalRole_maybe_helper co @@ -1376,7 +1388,7 @@ promoteCoercion co = case co of mkNomReflCo liftedTypeKind -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - FunCo _ _ _ + FunCo _ _ _ _ -> ASSERT( False ) mkNomReflCo liftedTypeKind @@ -1508,8 +1520,8 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co -- want it to be r. It is only called in 'mkPiCos', which is -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for -- now (Aug 2018) v won't occur in co. - mkFunCo r (mkReflCo r (varType v)) co - | otherwise = mkFunCo r (mkReflCo r (varType v)) co + mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co + | otherwise = mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above @@ -1888,7 +1900,7 @@ ty_co_subst lc role ty liftCoSubstTyVar lc r tv go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) - go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) + go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2) go r t@(ForAllTy (Bndr v _) ty) = let (lc', v', h) = liftCoSubstVarBndr lc v body_co = ty_co_subst lc' r ty in @@ -2125,7 +2137,7 @@ seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k `seq` seqCo co -seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 +seqCo (FunCo r w co1 co2) = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2 seqCo (CoVarCo cv) = cv `seq` () seqCo (HoleCo h) = coHoleCoVar h `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos @@ -2188,7 +2200,7 @@ coercionLKind co go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) go (AppCo co1 co2) = mkAppTy (go co1) (go co2) go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) - go (FunCo _ co1 co2) = mkFunctionType (go co1) (go co2) + go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) go (CoVarCo cv) = coVarLType cv go (HoleCo h) = coVarLType (coHoleCoVar h) go (UnivCo _ _ ty1 _) = ty1 @@ -2245,7 +2257,7 @@ coercionRKind co go (AppCo co1 co2) = mkAppTy (go co1) (go co2) go (CoVarCo cv) = coVarRType cv go (HoleCo h) = coVarRType (coHoleCoVar h) - go (FunCo _ co1 co2) = mkFunctionType (go co1) (go co2) + go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) go (UnivCo _ _ _ ty2) = ty2 go (SymCo co) = coercionLKind co go (TransCo _ co2) = go co2 @@ -2348,7 +2360,7 @@ coercionRole = go go (TyConAppCo r _ _) = r go (AppCo co1 _) = go co1 go (ForAllCo _ _ co) = go co - go (FunCo r _ _) = r + go (FunCo r _ _ _) = r go (CoVarCo cv) = coVarRole cv go (HoleCo h) = coVarRole (coHoleCoVar h) go (AxiomInstCo ax _ _) = coAxiomRole ax @@ -2454,9 +2466,9 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 ; _ -> False } ) mkNomReflCo ty1 - go (FunTy { ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_arg = arg2, ft_res = res2 }) - = mkFunCo Nominal (go arg1 arg2) (go res1 res2) + go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2) go (TyConApp tc1 args1) (TyConApp tc2 args2) = ASSERT( tc1 == tc2 ) diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot index eaf0180bef..7a92a84eb6 100644 --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -17,7 +17,7 @@ mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion -mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion mkCoVarCo :: CoVar -> Coercion mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index 6a8ac41650..4ecbb6cc3d 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -26,7 +26,7 @@ module GHC.Core.Coercion.Axiom ( Role(..), fsFromRole, CoAxiomRule(..), TypeEqn, - BuiltInSynFamily(..) + BuiltInSynFamily(..), trivialBuiltInFamily ) where import GHC.Prelude @@ -579,3 +579,11 @@ data BuiltInSynFamily = BuiltInSynFamily , sfInteractInert :: [Type] -> Type -> [Type] -> Type -> [TypeEqn] } + +-- Provides default implementations that do nothing. +trivialBuiltInFamily :: BuiltInSynFamily +trivialBuiltInFamily = BuiltInSynFamily + { sfMatchFam = \_ -> Nothing + , sfInteractTop = \_ _ -> [] + , sfInteractInert = \_ _ _ _ -> [] + } diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 18cb98767f..bb99f93ac6 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -251,14 +251,15 @@ opt_co4 env sym rep r (ForAllCo tv k_co co) opt_co4_wrap env' sym rep r co -- Use the "mk" functions to check for nested Refls -opt_co4 env sym rep r (FunCo _r co1 co2) +opt_co4 env sym rep r (FunCo _r cow co1 co2) = ASSERT( r == _r ) if rep - then mkFunCo Representational co1' co2' - else mkFunCo r co1' co2' + then mkFunCo Representational cow' co1' co2' + else mkFunCo r cow' co1' co2' where co1' = opt_co4_wrap env sym rep r co1 co2' = opt_co4_wrap env sym rep r co2 + cow' = opt_co1 env sym cow opt_co4 env sym rep r (CoVarCo cv) | Just co <- lookupCoVar (lcTCvSubst env) cv @@ -648,10 +649,10 @@ opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2 fireTransRule "PushTyConApp" in_co1 in_co2 $ mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) -opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) - = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case +opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b) + = ASSERT( r1 == r2) -- Just like the TyConAppCo/TyConAppCo case fireTransRule "PushFun" in_co1 in_co2 $ - mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b) opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) -- Must call opt_trans_rule_app; see Note [EtaAppCo] diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index c7f8f494eb..efe29f608f 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -39,6 +39,7 @@ import GHC.Types.Basic import GHC.Core.TyCo.Rep (Type, ThetaType) import GHC.Types.Var import GHC.Core.Type(mkTyConApp) +import GHC.Core.Multiplicity import qualified Data.Data as Data @@ -108,11 +109,11 @@ conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn -- | Returns just the instantiated /value/ argument types of a 'ConLike', -- (excluding dictionary args) -conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] +conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type] conLikeInstOrigArgTys (RealDataCon data_con) tys = dataConInstOrigArgTys data_con tys conLikeInstOrigArgTys (PatSynCon pat_syn) tys = - patSynInstArgTys pat_syn tys + map unrestricted $ patSynInstArgTys pat_syn tys -- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern -- synonyms, this will always consist of the universally quantified variables @@ -181,7 +182,7 @@ conLikeFullSig :: ConLike -> ([TyVar], [TyCoVar], [EqSpec] -- Why tyvars for universal but tycovars for existential? -- See Note [Existential coercion variables] in GHC.Core.DataCon - , ThetaType, ThetaType, [Type], Type) + , ThetaType, ThetaType, [Scaled Type], Type) conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con -- Required theta is empty as normal data cons require no additional diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index ca486863a5..e6f3d39690 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -30,11 +30,14 @@ module GHC.Core.DataCon ( dataConRepType, dataConInstSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTagZ, dataConTyCon, dataConOrigTyCon, - dataConUserType, + dataConWrapperType, + dataConNonlinearType, + dataConDisplayType, dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, dataConUserTyVars, dataConUserTyVarBinders, dataConEqSpec, dataConTheta, dataConStupidTheta, + dataConOtherTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, @@ -68,6 +71,7 @@ import GHC.Core.Type as Type import GHC.Core.Coercion import GHC.Core.Unify import GHC.Core.TyCon +import GHC.Core.Multiplicity import GHC.Types.FieldLabel import GHC.Core.Class import GHC.Types.Name @@ -83,6 +87,9 @@ import GHC.Utils.Binary import GHC.Types.Unique.Set import GHC.Types.Unique( mkAlphaTyVarUnique ) +import GHC.Driver.Session +import GHC.LanguageExtensions as LangExt + import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as LBS @@ -188,7 +195,7 @@ Note [Data constructor workers and wrappers] * Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments -* The wrapper (if it exists) takes dcOrigArgTys as its arguments +* The wrapper (if it exists) takes dcOrigArgTys as its arguments. The worker takes dataConRepArgTys as its arguments If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys @@ -412,7 +419,7 @@ data DataCon -- the wrapper Id, because that makes it harder to use the wrap-id -- to rebuild values after record selection or in generics. - dcOrigArgTys :: [Type], -- Original argument types + dcOrigArgTys :: [Scaled Type], -- Original argument types -- (before unboxing and flattening of strict fields) dcOrigResTy :: Type, -- Original result type, as seen by the user -- NB: for a data instance, the original user result type may @@ -595,7 +602,7 @@ sometimes refer to this as "the dcUserTyVarBinders invariant". dcUserTyVarBinders, as the name suggests, is the one that users will see most of the time. It's used when computing the type signature of a data constructor (see -dataConUserType), and as a result, it's what matters from a TypeApplications +dataConWrapperType), and as a result, it's what matters from a TypeApplications perspective. Note [The dcEqSpec domain invariant] @@ -640,9 +647,9 @@ data DataConRep , dcr_boxer :: DataConBoxer - , dcr_arg_tys :: [Type] -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* all evidence args + , dcr_arg_tys :: [Scaled Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys -- See also Note [Data-con worker strictness] @@ -944,7 +951,7 @@ mkDataCon :: Name -- See @Note [TyVarBinders in DataCons]@ -> [EqSpec] -- ^ GADT equalities -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper - -> [KnotTied Type] -- ^ Original argument types + -> [KnotTied (Scaled Type)] -- ^ Original argument types -> KnotTied Type -- ^ Original result type -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' -> KnotTied TyCon -- ^ Representation type constructor @@ -1002,8 +1009,8 @@ mkDataCon name declared_infix prom_info rep_ty = case rep of -- If the DataCon has no wrapper, then the worker's type *is* the - -- user-facing type, so we can simply use dataConUserType. - NoDataConRep -> dataConUserType con + -- user-facing type, so we can simply use dataConWrapperType. + NoDataConRep -> dataConWrapperType con -- If the DataCon has a wrapper, then the worker's type is never seen -- by the user. The visibilities we pick do not matter here. DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ @@ -1021,7 +1028,7 @@ mkDataCon name declared_infix prom_info prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) {- Invisible -} | (n,t) <- fresh_names `zip` theta ] prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) - {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] + {- Visible -} | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ] prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs prom_res_kind = orig_res_ty promoted = mkPromotedDataCon con name prom_info prom_bndrs @@ -1029,7 +1036,7 @@ mkDataCon name declared_infix prom_info roles = map (\tv -> if isTyVar tv then Nominal else Phantom) (univ_tvs ++ ex_tvs) - ++ map (const Representational) (theta ++ orig_arg_tys) + ++ map (const Representational) (theta ++ map scaledThing orig_arg_tys) freshNames :: [Name] -> [Name] -- Make an infinite list of Names whose Uniques and OccNames @@ -1206,7 +1213,7 @@ dataConFieldType con label = case dataConFieldType_maybe con label of dataConFieldType_maybe :: DataCon -> FieldLabelString -> Maybe (FieldLabel, Type) dataConFieldType_maybe con label - = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) + = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con)) -- | Strictness/unpack annotations, from user; or, for imported -- DataCons, from the interface file @@ -1270,7 +1277,7 @@ dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs univ_tys = ( ex_tvs' , substTheta subst (dataConTheta con) - , substTys subst arg_tys) + , substTys subst (map scaledThing arg_tys)) where univ_subst = zipTvSubst univ_tvs univ_tys (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs @@ -1290,11 +1297,12 @@ dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs -- equalities -- -- 5) The original argument types to the 'DataCon' (i.e. before --- any change of the representation of the type) +-- any change of the representation of the type) with linearity +-- annotations -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) @@ -1309,7 +1317,41 @@ dataConOrigResTy dc = dcOrigResTy dc dataConStupidTheta :: DataCon -> ThetaType dataConStupidTheta dc = dcStupidTheta dc -dataConUserType :: DataCon -> Type +{- +Note [Displaying linear fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constructor with a linear field can be written either as +MkT :: a #-> T a (with -XLinearTypes) +or +MkT :: a -> T a (with -XNoLinearTypes) + +There are two different methods to retrieve a type of a datacon. +They differ in how linear fields are handled. + +1. dataConWrapperType: +The type of the wrapper in Core. +For example, dataConWrapperType for Maybe is a #-> Just a. + +2. dataConNonlinearType: +The type of the constructor, with linear arrows replaced by unrestricted ones. +Used when we don't want to introduce linear types to user (in holes +and in types in hie used by haddock). + +3. dataConDisplayType (depends on DynFlags): +The type we'd like to show in error messages, :info and -ddump-types. +Ideally, it should reflect the type written by the user; +the function returns a type with arrows that would be required +to write this constructor under the current setting of -XLinearTypes. +In principle, this type can be different from the user's source code +when the value of -XLinearTypes has changed, but we don't +expect this to cause much trouble. + +Due to internal plumbing in checkValidDataCon, we can't just return a Doc. +The multiplicity of arrows returned by dataConDisplayType and +dataConDisplayType is used only for pretty-printing. +-} + +dataConWrapperType :: DataCon -> Type -- ^ The user-declared type of the data constructor -- in the nice-to-read form: -- @@ -1324,14 +1366,30 @@ dataConUserType :: DataCon -> Type -- -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. -dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, - dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) +dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) = mkInvisForAllTys user_tvbs $ - mkInvisFunTys theta $ + mkInvisFunTysMany theta $ mkVisFunTys arg_tys $ res_ty +dataConNonlinearType :: DataCon -> Type +dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys + in mkInvisForAllTys user_tvbs $ + mkInvisFunTysMany theta $ + mkVisFunTys arg_tys' $ + res_ty + +dataConDisplayType :: DynFlags -> DataCon -> Type +dataConDisplayType dflags dc + = if xopt LangExt.LinearTypes dflags + then dataConWrapperType dc + else dataConNonlinearType dc + -- | Finds the instantiated types of the arguments required to construct a -- 'DataCon' representation -- NB: these INCLUDE any dictionary args @@ -1341,13 +1399,13 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality -- However, it can have a dcTheta (notably it can be a -- class dictionary, with superclasses) -> [Type] -- ^ Instantiated at these types - -> [Type] + -> [Scaled Type] dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( univ_tvs `equalLength` inst_tys , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) ASSERT2( null ex_tvs, ppr dc ) - map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) + map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon', -- (excluding dictionary args) @@ -1355,7 +1413,7 @@ dataConInstOrigArgTys :: DataCon -- Works for any DataCon -> [Type] -- Includes existential tyvar args, but NOT -- equality constraints or dicts - -> [Type] + -> [Scaled Type] -- For vanilla datacons, it's all quite straightforward -- But for the call in GHC.HsToCore.Match.Constructor, we really do want just -- the value args @@ -1364,26 +1422,30 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( tyvars `equalLength` inst_tys , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTy subst) arg_tys + substScaledTys subst arg_tys where tyvars = univ_tvs ++ ex_tvs subst = zipTCvSubst tyvars inst_tys -- | Returns the argument types of the wrapper, excluding all dictionary arguments -- and without substituting for any type variables -dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys :: DataCon -> [Scaled Type] dataConOrigArgTys dc = dcOrigArgTys dc +-- | Returns constraints in the wrapper type, other than those in the dataConEqSpec +dataConOtherTheta :: DataCon -> ThetaType +dataConOtherTheta dc = dcOtherTheta dc + -- | Returns the arg types of the worker, including *all* non-dependent -- evidence, after any flattening has been done and without substituting for -- any type variables -dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys :: DataCon -> [Scaled Type] dataConRepArgTys (MkData { dcRep = rep , dcEqSpec = eq_spec , dcOtherTheta = theta , dcOrigArgTys = orig_arg_tys }) = case rep of - NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys + NoDataConRep -> ASSERT( null eq_spec ) (map unrestricted theta) ++ orig_arg_tys DCR { dcr_arg_tys = arg_tys } -> arg_tys -- | The string @package:module.name@ identifying a constructor, which is attached @@ -1502,7 +1564,7 @@ splitDataProductType_maybe -> Maybe (TyCon, -- The type constructor [Type], -- Type args of the tycon DataCon, -- The data constructor - [Type]) -- Its /representation/ arg types + [Scaled Type]) -- Its /representation/ arg types -- Rejecting existentials is conservative. Maybe some things -- could be made to work with them, but I'm not going to sweat diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot index 6520abbbe7..70c8328da1 100644 --- a/compiler/GHC/Core/DataCon.hs-boot +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -9,6 +9,7 @@ import GHC.Types.Unique ( Uniquable ) import GHC.Utils.Outputable ( Outputable, OutputableBndr ) import GHC.Types.Basic (Arity) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType ) +import GHC.Core.Multiplicity (Scaled) data DataCon data DataConRep @@ -21,10 +22,10 @@ dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] dataConSourceArity :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] +dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type] dataConStupidTheta :: DataCon -> ThetaType dataConFullSig :: DataCon - -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) isUnboxedSumCon :: DataCon -> Bool instance Eq DataCon diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index b562ffc38b..5d65eec042 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -76,6 +76,8 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.FamInstEnv +import GHC.Core.Multiplicity +import GHC.Builtin.Types( unrestrictedFunTyConName ) import GHC.Builtin.Types.Prim( funTyConName ) import GHC.Data.Maybe( orElse ) import GHC.Utils.Misc @@ -350,11 +352,17 @@ orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' -- Look through type synonyms (#4912) orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet -orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon +orphNamesOfType (TyConApp tycon tys) = func + `unionNameSet` orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys + where func = case tys of + arg:_ | tycon == funTyCon -> orph_names_of_fun_ty_con arg + _ -> emptyNameSet orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) `unionNameSet` orphNamesOfType res -orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See #8535 +orphNamesOfType (FunTy _ w arg res) = orph_names_of_fun_ty_con w + `unionNameSet` unitNameSet funTyConName + `unionNameSet` orphNamesOfType w `unionNameSet` orphNamesOfType arg `unionNameSet` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg @@ -378,7 +386,7 @@ orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` or orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (ForAllCo _ kind_co co) = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co -orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (FunCo _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (CoVarCo _) = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 @@ -428,6 +436,12 @@ orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) orphNamesOfFamInst :: FamInst -> NameSet orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) +-- Detect FUN 'Many as an application of (->), so that :i (->) works as expected +-- (see #8535) Issue #16475 describes a more robust solution +orph_names_of_fun_ty_con :: Mult -> NameSet +orph_names_of_fun_ty_con Many = unitNameSet unrestrictedFunTyConName +orph_names_of_fun_ty_con _ = emptyNameSet + {- ************************************************************************ * * @@ -716,9 +730,10 @@ freeVars = go where go :: CoreExpr -> CoreExprWithFVs go (Var v) - | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v) + | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v) | otherwise = (emptyDVarSet, AnnVar v) where + mult_vars = tyCoVarsOfTypeDSet (varMult v) ty_fvs = dVarTypeTyCoVars v -- See Note [The FVAnn invariant] diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 9d2c5c2f79..81221c25ed 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -1413,14 +1413,14 @@ normalise_type ty go (TyConApp tc tys) = normalise_tc_app tc tys go ty@(LitTy {}) = do { r <- getRole ; return (mkReflCo r ty, ty) } - go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] - go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + go ty@(FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) = do { (co1, nty1) <- go ty1 ; (co2, nty2) <- go ty2 + ; (wco, wty) <- go w ; r <- getRole - ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } + ; return (mkFunCo r wco co1 co2, ty { ft_mult = wty, ft_arg = nty1, ft_res = nty2 }) } go (ForAllTy (Bndr tcvar vis) ty) = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar ; (co, nty) <- withLC lc' $ normalise_type ty @@ -1749,10 +1749,11 @@ coreFlattenTy subst = go = let (env', tys') = coreFlattenTys subst env tys in (env', mkTyConApp tc tys') - go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, ty { ft_arg = ty1', ft_res = ty2' }) + (env2, ty2') = go env1 ty2 + (env3, mult') = go env2 mult in + (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' }) go env (ForAllTy (Bndr tv vis) ty) = let (env1, subst', tv') = coreFlattenVarBndr subst env tv @@ -1770,6 +1771,7 @@ coreFlattenTy subst = go = let (env', co') = coreFlattenCo subst env co in (env', CoercionTy co') + -- when flattening, we don't care about the contents of coercions. -- so, just return a fresh variable of the right (flattened) type coreFlattenCo :: TvSubstEnv -> FlattenEnv diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 314f9d0319..43c93595df 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -8,6 +8,7 @@ See Note [Core Lint guarantee]. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-} module GHC.Core.Lint ( @@ -34,12 +35,14 @@ import GHC.Data.Bag import GHC.Types.Literal import GHC.Core.DataCon import GHC.Builtin.Types.Prim +import GHC.Builtin.Types ( multiplicityTy ) import GHC.Tc.Utils.TcType ( isFloatingTy ) import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import GHC.Types.Name +import GHC.Types.Name.Env import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Ppr @@ -47,6 +50,8 @@ import GHC.Utils.Error import GHC.Core.Coercion import GHC.Types.SrcLoc import GHC.Core.Type as Type +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv import GHC.Types.RepType import GHC.Core.TyCo.Rep -- checks validity of types/coercions import GHC.Core.TyCo.Subst @@ -66,7 +71,7 @@ import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv ) -import GHC.Driver.Types +import GHC.Driver.Types hiding (Usage) import GHC.Driver.Session import Control.Monad import GHC.Utils.Monad @@ -471,7 +476,7 @@ lintCoreBindings dflags pass local_in_scope binds -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" binders = map fst all_pairs - flags = defaultLintFlags + flags = (defaultLintFlags dflags) { lf_check_global_ids = check_globals , lf_check_inline_loop_breakers = check_lbs , lf_check_static_ptrs = check_static_ptrs } @@ -541,7 +546,7 @@ lintUnfolding is_compulsory dflags locn var_set expr | otherwise = Just (pprMessageBag errs) where vars = nonDetEltsUniqSet var_set - (_warns, errs) = initL dflags defaultLintFlags vars $ + (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $ if is_compulsory -- See Note [Checking for levity polymorphism] then noLPChecks linter @@ -558,7 +563,7 @@ lintExpr dflags vars expr | isEmptyBag errs = Nothing | otherwise = Just (pprMessageBag errs) where - (_warns, errs) = initL dflags defaultLintFlags vars linter + (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter linter = addLoc TopLevelBindings $ lintCoreExpr expr @@ -572,24 +577,29 @@ lintExpr dflags vars expr Check a core binding, returning the list of variables bound. -} +-- Returns a UsageEnv because this function is called in lintCoreExpr for +-- Let + lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] - -> ([LintedId] -> LintM a) -> LintM a + -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv]) lintRecBindings top_lvl pairs thing_inside = lintIdBndrs top_lvl bndrs $ \ bndrs' -> - do { zipWithM_ lint_pair bndrs' rhss - ; thing_inside bndrs' } + do { ues <- zipWithM lint_pair bndrs' rhss + ; a <- thing_inside bndrs' + ; return (a, ues) } where (bndrs, rhss) = unzip pairs lint_pair bndr' rhs = addLoc (RhsOf bndr') $ - do { rhs_ty <- lintRhs bndr' rhs -- Check the rhs - ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty } + do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + ; return ue } -lintLetBody :: [LintedId] -> CoreExpr -> LintM LintedType +lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv) lintLetBody bndrs body - = do { body_ty <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) + = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) ; mapM_ (lintJoinBndrType body_ty) bndrs - ; return body_ty } + ; return (body_ty, body_ue) } lintLetBind :: TopLevelFlag -> RecFlag -> LintedId -> CoreExpr -> LintedType -> LintM () @@ -668,7 +678,8 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) ; addLoc (UnfoldingOf binder) $ - lintIdUnfolding binder binder_ty (idUnfolding binder) } + lintIdUnfolding binder binder_ty (idUnfolding binder) + ; return () } -- We should check the unfolding, if any, but this is tricky because -- the unfolding is a SimplifiableCoreExpr. Give up for now. @@ -680,7 +691,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- join point. -- -- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM LintedType +lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv) -- NB: the Id can be Linted or not -- it's only used for -- its OccInfo and join-pointer-hood lintRhs bndr rhs @@ -695,6 +706,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go where -- Allow occurrences of 'makeStatic' at the top-level but produce errors -- otherwise. + go :: StaticPtrCheck -> LintM (OutType, UsageEnv) go AllowAtTopLevel | (binders0, rhs') <- collectTyBinders rhs , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' @@ -703,15 +715,15 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go -- imitate @lintCoreExpr (Lam ...)@ lintLambda -- imitate @lintCoreExpr (App ...)@ - (do fun_ty <- lintCoreExpr fun - lintCoreArgs fun_ty [Type t, info, e] + (do fun_ty_ue <- lintCoreExpr fun + lintCoreArgs fun_ty_ue [Type t, info, e] ) binders0 go _ = markAllJoinsBad $ lintCoreExpr rhs -- | Lint the RHS of a join point with expected join arity of @n@ (see Note -- [Join points] in GHC.Core). -lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM LintedType +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv) lintJoinLams join_arity enforce rhs = go join_arity rhs where @@ -729,10 +741,10 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty uf | isStableUnfolding uf , Just rhs <- maybeUnfoldingTemplate uf - = do { ty <- if isCompulsoryUnfolding uf - then noLPChecks $ lintRhs bndr rhs - -- See Note [Checking for levity polymorphism] - else lintRhs bndr rhs + = do { ty <- fst <$> (if isCompulsoryUnfolding uf + then noLPChecks $ lintRhs bndr rhs + -- See Note [Checking for levity polymorphism] + else lintRhs bndr rhs) ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } lintIdUnfolding _ _ _ = return () -- Do not Lint unstable unfoldings, because that leads @@ -825,7 +837,7 @@ lintCastExpr expr expr_ty co ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; return to_ty } -lintCoreExpr :: CoreExpr -> LintM LintedType +lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv) -- The returned type has the substitution from the monad -- already applied to it: -- lintCoreExpr e subst = exprType (subst e) @@ -839,11 +851,12 @@ lintCoreExpr (Var var) = lintIdOcc var 0 lintCoreExpr (Lit lit) - = return (literalType lit) + = return (literalType lit, zeroUE) lintCoreExpr (Cast expr co) - = do expr_ty <- markAllJoinsBad $ lintCoreExpr expr - lintCastExpr expr expr_ty co + = do (expr_ty, ue) <- markAllJoinsBad $ lintCoreExpr expr + to_ty <- lintCastExpr expr expr_ty co + return (to_ty, ue) lintCoreExpr (Tick tickish expr) = do case tickish of @@ -875,12 +888,13 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) lintCoreExpr (Let (NonRec bndr rhs) body) | isId bndr = do { -- First Lint the RHS, before bringing the binder into scope - rhs_ty <- lintRhs bndr rhs + (rhs_ty, let_ue) <- lintRhs bndr rhs + -- See Note [Multiplicity of let binders] in Var -- Now lint the binder ; lintBinder LetBind bndr $ \bndr' -> do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty - ; lintLetBody [bndr'] body } } + ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } } | otherwise = failWithL (mkLetErr bndr rhs) -- Not quite accurate @@ -897,8 +911,11 @@ lintCoreExpr e@(Let (Rec pairs) body) ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ mkInconsistentRecMsg bndrs - ; lintRecBindings NotTopLevel pairs $ \ bndrs' -> - lintLetBody bndrs' body } + -- See Note [Multiplicity of let binders] in Var + ; ((body_type, body_ue), ues) <- + lintRecBindings NotTopLevel pairs $ \ bndrs' -> + lintLetBody bndrs' body + ; return (body_type, body_ue `addUE` scaleUE Many (foldr1 addUE ues)) } where bndrs = map fst pairs @@ -908,19 +925,20 @@ lintCoreExpr e@(App _ _) -- N.B. we may have an over-saturated application of the form: -- runRW (\s -> \x -> ...) y , arg_ty1 : arg_ty2 : arg3 : rest <- args - = do { fun_ty1 <- lintCoreArg (idType fun) arg_ty1 - ; fun_ty2 <- lintCoreArg fun_ty1 arg_ty2 + = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1 + ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2 -- See Note [Linting of runRW#] - ; let lintRunRWCont :: CoreArg -> LintM LintedType + ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) lintRunRWCont (Cast expr co) = do - ty <- lintRunRWCont expr - lintCastExpr expr ty co + (ty, ue) <- lintRunRWCont expr + new_ty <- lintCastExpr expr ty co + return (new_ty, ue) lintRunRWCont expr@(Lam _ _) = do lintJoinLams 1 (Just fun) expr lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other -- TODO: Look through ticks? - ; arg3_ty <- lintRunRWCont arg3 - ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty + ; (arg3_ty, ue3) <- lintRunRWCont arg3 + ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3 ; lintCoreArgs app_ty rest } | Var fun <- fun @@ -928,8 +946,8 @@ lintCoreExpr e@(App _ _) = failWithL (text "Invalid runRW# application") | otherwise - = do { fun_ty <- lintCoreFun fun (length args) - ; lintCoreArgs fun_ty args } + = do { pair <- lintCoreFun fun (length args) + ; lintCoreArgs pair args } where (fun, args) = collectArgs e @@ -948,11 +966,11 @@ lintCoreExpr (Type ty) lintCoreExpr (Coercion co) = do { co' <- addLoc (InCo co) $ lintCoercion co - ; return (coercionType co') } + ; return (coercionType co', zeroUE) } ---------------------- lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed - -> LintM LintedType -- returns type of the *variable* + -> LintM (LintedType, UsageEnv) -- returns type of the *variable* lintIdOcc var nargs = addLoc (OccOf var) $ do { checkL (isNonCoVarId var) @@ -986,11 +1004,13 @@ lintIdOcc var nargs ; checkDeadIdOcc var ; checkJoinOcc var nargs - ; return linted_bndr_ty } + ; usage <- varCallSiteUsage var + + ; return (linted_bndr_ty, usage) } lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM LintedType -- Returns type of the *function* + -> Int -- Number of arguments (type or val) being passed + -> LintM (LintedType, UsageEnv) -- Returns type of the *function* lintCoreFun (Var var) nargs = lintIdOcc var nargs @@ -1005,12 +1025,13 @@ lintCoreFun expr nargs -- See Note [Join points are less general than the paper] lintCoreExpr expr ------------------ -lintLambda :: Var -> LintM Type -> LintM Type +lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) lintLambda var lintBody = addLoc (LambdaBodyOf var) $ lintBinder LambdaBind var $ \ var' -> - do { body_ty <- lintBody - ; return (mkLamType var' body_ty) } + do { (body_ty, ue) <- lintBody + ; ue' <- checkLinearity ue var' + ; return (mkLamType var' body_ty, ue') } ------------------ checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... @@ -1068,6 +1089,19 @@ checkJoinOcc var n_args | otherwise = return () +-- Check that the usage of var is consistent with var itself, and pop the var +-- from the usage environment (this is important because of shadowing). +checkLinearity :: UsageEnv -> Var -> LintM UsageEnv +checkLinearity body_ue lam_var = + case varMultMaybe lam_var of + Just mult -> do ensureSubUsage lhs mult (err_msg mult) + return $ deleteUE body_ue lam_var + Nothing -> return body_ue -- A type variable + where + lhs = lookupUE body_ue lam_var + err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var + $$ ppr lhs <+> text "⊈" <+> ppr mult + {- Note [No alternatives lint check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1150,19 +1184,20 @@ subtype of the required type, as one would expect. -} -lintCoreArgs :: LintedType -> [CoreArg] -> LintM LintedType -lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args +lintCoreArgs :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv) +lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args -lintCoreArg :: LintedType -> CoreArg -> LintM LintedType -lintCoreArg fun_ty (Type arg_ty) +lintCoreArg :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv) +lintCoreArg (fun_ty, ue) (Type arg_ty) = do { checkL (not (isCoercionTy arg_ty)) (text "Unnecessary coercion-to-type injection:" <+> ppr arg_ty) ; arg_ty' <- lintType arg_ty - ; lintTyApp fun_ty arg_ty' } + ; res <- lintTyApp fun_ty arg_ty' + ; return (res, ue) } -lintCoreArg fun_ty arg - = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg +lintCoreArg (fun_ty, fun_ue) arg + = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg -- See Note [Levity polymorphism invariants] in GHC.Core ; flags <- getLintFlags ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty)) @@ -1173,24 +1208,53 @@ lintCoreArg fun_ty arg ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) (mkLetAppMsg arg) - ; lintValApp arg fun_ty arg_ty } + ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } ----------------- -lintAltBinders :: LintedType -- Scrutinee type +lintAltBinders :: UsageEnv + -> Var -- Case binder + -> LintedType -- Scrutinee type -> LintedType -- Constructor type - -> [OutVar] -- Binders - -> LintM () + -> [(Mult, OutVar)] -- Binders + -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintAltBinders scrut_ty con_ty [] - = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) -lintAltBinders scrut_ty con_ty (bndr:bndrs) +lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] + = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) + ; return rhs_ue } +lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) | isTyVar bndr = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } + ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } | otherwise - = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) - ; lintAltBinders scrut_ty con_ty' bndrs } + = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE + -- We can pass zeroUE to lintValApp because we ignore its usage + -- calculation and compute it in the call for checkCaseLinearity below. + ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr + ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + +-- | Implements the case rules for linearity +checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv +checkCaseLinearity ue case_bndr var_w bndr = do + ensureSubUsage lhs rhs err_msg + lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr) + return $ deleteUE ue bndr + where + lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) + rhs = case_bndr_w `mkMultMul` var_w + err_msg = (text "Linearity failure in variable:" <+> ppr bndr + $$ ppr lhs <+> text "⊈" <+> ppr rhs + $$ text "Computed by:" + <+> text "LHS:" <+> lhs_formula + <+> text "RHS:" <+> rhs_formula) + lhs_formula = ppr bndr_usage <+> text "+" + <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) + rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w + case_bndr_w = varMult case_bndr + case_bndr_usage = lookupUE ue case_bndr + bndr_usage = lookupUE ue bndr + + ----------------- lintTyApp :: LintedType -> LintedType -> LintM LintedType @@ -1211,11 +1275,12 @@ lintTyApp fun_ty arg_ty -- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ -- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the -- application. -lintValApp :: CoreExpr -> LintedType -> LintedType -> LintM LintedType -lintValApp arg fun_ty arg_ty - | Just (arg_ty', res_ty') <- splitFunTy_maybe fun_ty +lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) +lintValApp arg fun_ty arg_ty fun_ue arg_ue + | Just (Scaled w arg_ty', res_ty') <- splitFunTy_maybe fun_ty = do { ensureEqTys arg_ty' arg_ty err1 - ; return res_ty' } + ; let app_ue = addUE fun_ue (scaleUE w arg_ue) + ; return (res_ty', app_ue) } | otherwise = failWithL err2 where @@ -1242,14 +1307,15 @@ lintTyKind tyvar arg_ty ************************************************************************ -} -lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM LintedType +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv) lintCaseExpr scrut var alt_ty alts = do { let e = Case scrut var alt_ty alts -- Just for error messages -- Check the scrutinee - ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut + ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut -- See Note [Join points are less general than the paper] -- in GHC.Core + ; let scrut_mult = varMult var ; alt_ty <- addLoc (CaseTy scrut) $ lintValueType alt_ty @@ -1292,9 +1358,10 @@ lintCaseExpr scrut var alt_ty alts = ; lintBinder CaseBind var $ \_ -> do { -- Check the alternatives - mapM_ (lintCoreAlt scrut_ty alt_ty) alts + ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts + ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues ; checkCaseAlts e scrut_ty alts - ; return alt_ty } } + ; return (alt_ty, case_ue) } } checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty @@ -1336,23 +1403,26 @@ checkCaseAlts e ty alts = Nothing -> False Just tycon -> isPrimTyCon tycon -lintAltExpr :: CoreExpr -> LintedType -> LintM () +lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv lintAltExpr expr ann_ty - = do { actual_ty <- lintCoreExpr expr - ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } + = do { (actual_ty, ue) <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) + ; return ue } -- See GHC.Core Note [Case expression invariants] item (6) -lintCoreAlt :: LintedType -- Type of scrutinee - -> LintedType -- Type of the alternative +lintCoreAlt :: Var -- Case binder + -> LintedType -- Type of scrutinee + -> Mult -- Multiplicity of scrutinee + -> LintedType -- Type of the alternative -> CoreAlt - -> LintM () + -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = +lintCoreAlt _ _ _ alt_ty (DEFAULT, args, rhs) = do { lintL (null args) (mkDefaultArgsMsg args) ; lintAltExpr rhs alt_ty } -lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) +lintCoreAlt _case_bndr scrut_ty _ alt_ty (LitAlt lit, args, rhs) | litIsLifted lit = failWithL integerScrutinisedMsg | otherwise @@ -1362,24 +1432,51 @@ lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) where lit_ty = literalType lit -lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(DataAlt con, args, rhs) | isNewTyCon (dataConTyCon con) - = addErrL (mkNewTyDataConAltMsg scrut_ty alt) + = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty = addLoc (CaseAlt alt) $ do { -- First instantiate the universally quantified -- type variables of the data constructor -- We've already check lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + ; ex_tvs_n = length (dataConExTyCoVars con) + -- See Note [Alt arg multiplicities] + ; multiplicities = replicate ex_tvs_n Many ++ + map scaledMult (dataConRepArgTys con) } -- And now bring the new binders into scope ; lintBinders CasePatBind args $ \ args' -> do - { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') - ; lintAltExpr rhs alt_ty } } + { + rhs_ue <- lintAltExpr rhs alt_ty + ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities args')) + ; return $ deleteUE rhs_ue' case_bndr + } + } | otherwise -- Scrut-ty is wrong shape - = addErrL (mkBadAltMsg scrut_ty alt) + = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) + +lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () +lintLinearBinder doc actual_usage described_usage + = ensureSubMult actual_usage described_usage err_msg + where + err_msg = (text "Multiplicity of variable does not agree with its context" + $$ doc + $$ ppr actual_usage + $$ text "Annotation:" <+> ppr described_usage) + +{- +Note [Alt arg multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is necessary to use `dataConRepArgTys` so you get the arg tys from +the wrapper if there is one. + +You also need to add the existential ty vars as they are passed are arguments +but not returned by `dataConRepArgTys`. Without this the test `GADT1` fails. +-} {- ************************************************************************ @@ -1498,7 +1595,7 @@ lintTypes dflags vars tys | isEmptyBag errs = Nothing | otherwise = Just (pprMessageBag errs) where - (_warns, errs) = initL dflags defaultLintFlags vars linter + (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter linter = lintBinders LambdaBind vars $ \_ -> mapM_ lintType tys @@ -1559,7 +1656,7 @@ lintType ty@(TyConApp tc tys) ; lintTySynFamApp report_unsat ty tc tys } | isFunTyCon tc - , tys `lengthIs` 4 + , tys `lengthIs` 5 -- We should never see a saturated application of funTyCon; such -- applications should be represented with the FunTy constructor. -- See Note [Linting function types] and @@ -1574,11 +1671,12 @@ lintType ty@(TyConApp tc tys) -- arrows can related *unlifted* kinds, so this has to be separate from -- a dependent forall. -lintType ty@(FunTy af t1 t2) +lintType ty@(FunTy af tw t1 t2) = do { t1' <- lintType t1 ; t2' <- lintType t2 - ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' - ; return (FunTy af t1' t2') } + ; tw' <- lintType tw + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw' + ; return (FunTy af tw' t1' t2') } lintType ty@(ForAllTy (Bndr tcv vis) body_ty) | not (isTyCoVar tcv) @@ -1673,16 +1771,18 @@ checkValueType ty doc kind = typeKind ty ----------------- -lintArrow :: SDoc -> LintedType -> LintedType -> LintM () +lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintArrow what t1 t2 -- Eg lintArrow "type or kind `blah'" k1 k2 - -- or lintArrow "coercion `blah'" k1 k2 +lintArrow what t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw + -- or lintArrow "coercion `blah'" k1 k2 kw = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) - ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) } + ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) + ; unless (isMultiplicityTy kw) (addErrL (msg (text "multiplicity") kw)) } where k1 = typeKind t1 k2 = typeKind t2 + kw = typeKind tw msg ar k = vcat [ hang (text "Ill-kinded" <+> ar) 2 (text "in" <+> what) @@ -1729,7 +1829,7 @@ lint_app doc kfn arg_tys | Just kfn' <- coreView kfn = go_app in_scope kfn' ta - go_app _ fun_kind@(FunTy _ kfa kfb) ta + go_app _ fun_kind@(FunTy _ _ kfa kfb) ta = do { let ka = typeKind ta ; unless (ka `eqType` kfa) $ addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) @@ -1759,8 +1859,8 @@ lintCoreRule _ _ (BuiltinRule {}) lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs , ru_args = args, ru_rhs = rhs }) = lintBinders LambdaBind bndrs $ \ _ -> - do { lhs_ty <- lintCoreArgs fun_ty args - ; rhs_ty <- case isJoinId_maybe fun of + do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args + ; (rhs_ty, _) <- case isJoinId_maybe fun of Just join_arity -> do { checkL (args `lengthIs` join_arity) $ mkBadJoinPointRuleMsg fun join_arity rule @@ -1923,7 +2023,7 @@ lintCoercion (GRefl r ty (MCo co)) lintCoercion co@(TyConAppCo r tc cos) | tc `hasKey` funTyConKey - , [_rep1,_rep2,_co1,_co2] <- cos + , [_w, _rep1,_rep2,_co1,_co2] <- cos = failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) -- All saturated TyConAppCos should be FunCos @@ -1990,16 +2090,24 @@ lintCoercion co@(ForAllCo tcv kind_co body_co) ; return (ForAllCo tcv' kind_co' body_co') } } -lintCoercion co@(FunCo r co1 co2) +lintCoercion co@(FunCo r cow co1 co2) = do { co1' <- lintCoercion co1 ; co2' <- lintCoercion co2 + ; cow' <- lintCoercion cow ; let Pair lt1 rt1 = coercionKind co1 Pair lt2 rt2 = coercionKind co2 - ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 - ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 + Pair ltw rtw = coercionKind cow + ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 ltw + ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 rtw ; lintRole co1 r (coercionRole co1) ; lintRole co2 r (coercionRole co2) - ; return (FunCo r co1' co2') } + ; ensureEqTys (typeKind ltw) multiplicityTy (text "coercion" <> quotes (ppr co)) + ; ensureEqTys (typeKind rtw) multiplicityTy (text "coercion" <> quotes (ppr co)) + ; let expected_mult_role = case r of + Phantom -> Phantom + _ -> Nominal + ; lintRole cow expected_mult_role (coercionRole cow) + ; return (FunCo r cow' co1' co2') } -- See Note [Bad unsafe coercion] lintCoercion co@(UnivCo prov r ty1 ty2) @@ -2269,6 +2377,9 @@ data LintEnv -- See Note [Join points] , le_dynflags :: DynFlags -- DynamicFlags + , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the + -- alias-like binders, as found in + -- non-recursive lets. } data LintFlags @@ -2276,6 +2387,7 @@ data LintFlags , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] , lf_check_levity_poly :: Bool -- See Note [Checking for levity polymorphism] } @@ -2289,13 +2401,14 @@ data StaticPtrCheck -- ^ Reject any 'makeStatic' occurrence. deriving Eq -defaultLintFlags :: LintFlags -defaultLintFlags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True - , lf_check_static_ptrs = AllowAnywhere - , lf_report_unsat_syns = True - , lf_check_levity_poly = True - } +defaultLintFlags :: DynFlags -> LintFlags +defaultLintFlags dflags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags + , lf_report_unsat_syns = True + , lf_check_levity_poly = True + } newtype LintM a = LintM { unLintM :: @@ -2371,6 +2484,25 @@ we behave as follows (#15057, #T15664): * If lf_report_unsat_syns is on, expand the synonym application and lint the result. Reason: want to check that synonyms are saturated when the type is expanded. + +Note [Linting linearity] +~~~~~~~~~~~~~~~~~~~~~~~~ +There are two known optimisations that have not yet been updated +to work with Linear Lint: + +* Lambda-bound variables with unfoldings + (see Note [Case binders and join points] and ticket #17530) +* Optimisations can create a letrec which uses a variable linearly, e.g. + letrec f True = f False + f False = x + in f True + uses 'x' linearly, but this is not seen by the linter. + Plan: make let-bound variables remember the usage environment. + See test LinearLetRec and https://github.com/tweag/ghc/issues/405. + +We plan to fix both of the issues in the very near future. +For now, linear Lint is disabled by default and +has to be enabled manually with -dlinear-core-lint. -} instance Applicative LintM where @@ -2423,7 +2555,8 @@ initL dflags flags vars m , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] , le_joins = emptyVarSet , le_loc = [] - , le_dynflags = dflags } + , le_dynflags = dflags + , le_ue_aliases = emptyNameEnv } setReportUnsat :: Bool -> LintM a -> LintM a -- Switch off lf_report_unsat_syns @@ -2536,6 +2669,9 @@ getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) getTCvSubst :: LintM TCvSubst getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) +getUEAliases :: LintM (NameEnv UsageEnv) +getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs)) + getInScope :: LintM InScopeSet getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) @@ -2577,12 +2713,48 @@ lookupJoinId id Just id' -> return (isJoinId_maybe id') Nothing -> return Nothing } +addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a +addAliasUE id ue thing_inside = LintM $ \ env errs -> + let new_ue_aliases = + extendNameEnv (le_ue_aliases env) (getName id) ue + in + unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs + +varCallSiteUsage :: Id -> LintM UsageEnv +varCallSiteUsage id = + do m <- getUEAliases + return $ case lookupNameEnv m (getName id) of + Nothing -> unitUE id One + Just id_ue -> id_ue + ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have already had the substitution applied ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg +ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () +ensureSubUsage Bottom _ _ = return () +ensureSubUsage Zero described_mult err_msg = ensureSubMult Many described_mult err_msg +ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg + +ensureSubMult :: Mult -> Mult -> SDoc -> LintM () +ensureSubMult actual_usage described_usage err_msg = do + flags <- getLintFlags + when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of + Submult -> return () + Unknown -> case actual_usage' of + MultMul m1 m2 -> ensureSubMult m1 described_usage' err_msg >> + ensureSubMult m2 described_usage' err_msg + _ -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) + + where actual_usage' = normalize actual_usage + described_usage' = normalize described_usage + + normalize :: Mult -> Mult + normalize (MultMul m1 m2) = mkMultMul (normalize m1) (normalize m2) + normalize m = m + lintRole :: Outputable thing => thing -- where the role appeared -> Role -- expected diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 2156ce70ce..9ea1ed85e0 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -72,6 +72,7 @@ import GHC.Hs.Utils ( mkChunkified, chunkify ) import GHC.Core.Type import GHC.Core.Coercion ( isCoVar ) import GHC.Core.DataCon ( DataCon, dataConWorkId ) +import GHC.Core.Multiplicity import GHC.Builtin.Types.Prim import GHC.Types.Id.Info import GHC.Types.Demand @@ -168,16 +169,16 @@ mkCoreAppTyped d (fun, fun_ty) arg where (arg_ty, res_ty) = splitFunTy fun_ty -mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -- Build an application (e1 e2), -- or a strict binding (case e2 of x -> e1 x) -- using the latter when necessary to respect the let/app invariant -- See Note [Core let/app invariant] in GHC.Core -mkValApp fun arg arg_ty res_ty +mkValApp fun arg (Scaled w arg_ty) res_ty | not (needsCaseBinding arg_ty arg) = App fun arg -- The vastly common case | otherwise - = mkStrictApp fun arg arg_ty res_ty + = mkStrictApp fun arg (Scaled w arg_ty) res_ty {- ********************************************************************* * * @@ -186,33 +187,33 @@ mkValApp fun arg arg_ty res_ty ********************************************************************* -} mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder pred +mkWildEvBinder pred = mkWildValBinder Many pred -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very -- easy to get into difficulties with shadowing. That's why it is used so little. -- See Note [WildCard binders] in GHC.Core.Opt.Simplify.Env -mkWildValBinder :: Type -> Id -mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty +mkWildValBinder :: Mult -> Type -> Id +mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName w ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. -mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +mkWildCase :: CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr -- Make a case expression whose case binder is unused -- The alts and res_ty should not have any occurrences of WildId -mkWildCase scrut scrut_ty res_ty alts - = Case scrut (mkWildValBinder scrut_ty) res_ty alts +mkWildCase scrut (Scaled w scrut_ty) res_ty alts + = Case scrut (mkWildValBinder w scrut_ty) res_ty alts -mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -- Build a strict application (case e2 of x -> e1 x) -mkStrictApp fun arg arg_ty res_ty +mkStrictApp fun arg (Scaled w arg_ty) res_ty = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] -- mkDefaultCase looks attractive here, and would be sound. -- But it uses (exprType alt_rhs) to compute the result type, -- whereas here we already know that the result type is res_ty where - arg_id = mkWildValBinder arg_ty + arg_id = mkWildValBinder w arg_ty -- Lots of shadowing, but it doesn't matter, -- because 'fun' and 'res_ty' should not have a free wild-id -- @@ -226,7 +227,7 @@ mkStrictApp fun arg arg_ty res_ty mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr -- Not going to be refining, so okay to take the type of the "then" clause - = mkWildCase guard boolTy (exprType then_expr) + = mkWildCase guard (linear boolTy) (exprType then_expr) [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! (DataAlt trueDataCon, [], then_expr) ] @@ -236,7 +237,7 @@ castBottomExpr :: CoreExpr -> Type -> CoreExpr -- See Note [Empty case alternatives] in GHC.Core castBottomExpr e res_ty | e_ty `eqType` res_ty = e - | otherwise = Case e (mkWildValBinder e_ty) res_ty [] + | otherwise = Case e (mkWildValBinder One e_ty) res_ty [] where e_ty = exprType e @@ -448,6 +449,10 @@ unitExpr = Var unitDataConId -- just the identity. -- -- 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' +-- times. And all the argument variables must have multiplicity 'Many'. mkTupleSelector, mkTupleSelector1 :: [Id] -- ^ The 'Id's to pattern match the tuple against -> Id -- ^ The 'Id' to select @@ -542,7 +547,7 @@ mkTupleCase uniqs vars body scrut_var scrut one_tuple_case chunk_vars (us, vs, body) = let (uniq, us') = takeUniqFromSupply us - scrut_var = mkSysLocal (fsLit "ds") uniq + scrut_var = mkSysLocal (fsLit "ds") uniq Many (mkBoxedTupleTy (map idType chunk_vars)) body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) in (us', scrut_var:vs, body') @@ -648,8 +653,8 @@ mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m) mkBuildExpr elt_ty mk_build_inside = do n_tyvar <- newTyVar alphaTyVar let n_ty = mkTyVarTy n_tyvar - c_ty = mkVisFunTys [elt_ty, n_ty] n_ty - [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] + c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty + [c, n] <- sequence [mkSysLocalM (fsLit "c") Many c_ty, mkSysLocalM (fsLit "n") Many n_ty] build_inside <- mk_build_inside (c, c_ty) (n, n_ty) @@ -874,7 +879,7 @@ runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a -- See Note [Error and friends have an "open-tyvar" forall] runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] - (mkVisFunTy addrPrimTy openAlphaTy) + (mkVisFunTyMany addrPrimTy openAlphaTy) {- Note [Error and friends have an "open-tyvar" forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -964,7 +969,7 @@ be relying on anything from it. aBSENT_ERROR_ID = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info where - absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) + absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy) -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for -- lifted-type things; see Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils arity_info = vanillaIdInfo `setArityInfo` 1 diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs index 6fc041887d..f8304d0d25 100644 --- a/compiler/GHC/Core/Map.hs +++ b/compiler/GHC/Core/Map.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module GHC.Core.Map ( -- * Maps over Core expressions @@ -179,7 +180,8 @@ data CoreMapX a instance Eq (DeBruijn CoreExpr) where D env1 e1 == D env2 e2 = go e1 e2 where - go (Var v1) (Var v2) = case (lookupCME env1 v1, lookupCME env2 v2) of + go (Var v1) (Var v2) + = case (lookupCME env1 v1, lookupCME env2 v2) of (Just b1, Just b2) -> b1 == b2 (Nothing, Nothing) -> v1 == v2 _ -> False @@ -193,6 +195,7 @@ instance Eq (DeBruijn CoreExpr) where go (Lam b1 e1) (Lam b2 e2) = D env1 (varType b1) == D env2 (varType b2) + && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) @@ -520,8 +523,8 @@ instance Eq (DeBruijn Type) where -> D env t1 == D env' t1' && D env t2 == D env' t2' (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' - (FunTy _ t1 t2, FunTy _ t1' t2') - -> D env t1 == D env' t1' && D env t2 == D env' t2' + (FunTy _ w1 t1 t2, FunTy _ w1' t1' t2') + -> D env w1 == D env w1' && D env t1 == D env' t1' && D env t2 == D env' t2' (TyConApp tc tys, TyConApp tc' tys') -> tc == tc' && D env tys == D env' tys' (LitTy l, LitTy l') @@ -745,6 +748,11 @@ instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where D env xs == D env' xs' _ == _ = False +instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where + D _ Nothing == D _ Nothing = True + D env (Just x) == D env' (Just x') = D env x == D env' x' + _ == _ = False + --------- Variable binders ------------- -- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between @@ -753,7 +761,26 @@ instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where -- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: -- we can disambiguate this by matching on the type (or kind, if this -- a binder in a type) of the binder. -type BndrMap = TypeMapG +-- +-- We also need to do the same for multiplicity! Which, since multiplicities are +-- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries +-- of pairs are composition. +data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a)) + +instance TrieMap BndrMap where + type Key BndrMap = Var + emptyTM = BndrMap emptyTM + lookupTM = lkBndr emptyCME + alterTM = xtBndr emptyCME + foldTM = fdBndrMap + mapTM = mapBndrMap + +mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b +mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm) + +fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b +fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm + -- Note [Binders] -- ~~~~~~~~~~~~~~ @@ -761,10 +788,15 @@ type BndrMap = TypeMapG -- of these data types have binding forms. lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a -lkBndr env v m = lkG (D env (varType v)) m +lkBndr env v (BndrMap tymap) = do + multmap <- lkG (D env (varType v)) tymap + lookupTM (D env <$> varMultMaybe v) multmap + + +xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v xt (BndrMap tymap) = + BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt)) -xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a -xtBndr env v f = xtG (D env (varType v)) f --------- Variable occurrence ------------- data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable diff --git a/compiler/GHC/Core/Multiplicity.hs b/compiler/GHC/Core/Multiplicity.hs new file mode 100644 index 0000000000..a4203fa6e0 --- /dev/null +++ b/compiler/GHC/Core/Multiplicity.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +{-| +This module defines the semi-ring of multiplicities, and associated functions. +Multiplicities annotate arrow types to indicate the linearity of the +arrow (in the sense of linear types). + +Mult is a type synonym for Type, used only when its kind is Multiplicity. +To simplify dealing with multiplicities, functions such as +mkMultMul perform simplifications such as Many * x = Many on the fly. +-} +module GHC.Core.Multiplicity + ( Mult + , pattern One + , pattern Many + , pattern MultMul + , mkMultAdd + , mkMultMul + , mkMultSup + , Scaled(..) + , scaledMult + , scaledThing + , unrestricted + , linear + , tymult + , irrelevantMult + , mkScaled + , scaledSet + , scaleScaled + , IsSubmult(..) + , submult + , mapScaledType) where + +import GHC.Prelude + +import Data.Data +import GHC.Utils.Outputable +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) +import {-# SOURCE #-} GHC.Builtin.Types ( oneDataConTy, manyDataConTy, multMulTyCon ) +import {-# SOURCE #-} GHC.Core.Type( eqType, splitTyConApp_maybe, mkTyConApp ) +import GHC.Builtin.Names (multMulTyConKey) +import GHC.Types.Unique (hasKey) + +{- +Note [Linear types] +~~~~~~~~~~~~~~~~~~~ +This module is the entry point for linear types. + +The detailed design is in the _Linear Haskell_ article +[https://arxiv.org/abs/1710.09756]. Other important resources in the linear +types implementation wiki page +[https://gitlab.haskell.org/ghc/ghc/wikis/linear-types/implementation], and the +proposal [https://github.com/ghc-proposals/ghc-proposals/pull/111] which +describes the concrete design at length. + +For the busy developer, though, here is a high-level view of linear types is the following: + +- Function arrows are annotated with a multiplicity (as defined by type `Mult` + and its smart constructors in this module) + - Because, as a type constructor, the type of function now has an extra + argument, the notation (->) is no longer suitable. We named the function + type constructor `FUN`. + - (->) retains its backward compatible meaning: `(->) a b = a -> b`. To + achieve this, `(->)` is defined as a type synonym to `FUN Many` (see + below). +- Multiplicities can be reified in Haskell as types of kind + `GHC.Types.Multiplicity` +- Ground multiplicity (that is, without a variable) can be `One` or `Many` + (`Many` is generally rendered as ω in the scientific literature). + Functions whose type is annotated with `One` are linear functions, functions whose + type is annotated with `Many` are regular functions, often called “unrestricted” + to contrast them with linear functions. +- A linear function is defined as a function such that *if* its result is + consumed exactly once, *then* its argument is consumed exactly once. You can + think of “consuming exactly once” as evaluating a value in normal form exactly + once (though not necessarily in one go). The _Linear Haskell_ article (see + infra) has a more precise definition of “consuming exactly once”. +- Data types can have unrestricted fields (the canonical example being the + `Unrestricted` data type), then these don't need to be consumed for a value to + be consumed exactly once. So consuming a value of type `Unrestricted` exactly + once means forcing it at least once. +- Why “at least once”? Because if `case u of { C x y -> f (C x y) }` is linear + (provided `f` is a linear function). So we might as well have done `case u of + { !z -> f z }`. So, we can observe constructors as many times as we want, and + we are actually allowed to force the same thing several times because laziness + means that we are really forcing a the value once, and observing its + constructor several times. The type checker and the linter recognise some (but + not all) of these multiple forces as indeed linear. Mostly just enough to + support variable patterns. +- Multiplicities form a semiring. +- Multiplicities can also be variables and we can universally quantify over + these variables. This is referred to as “multiplicity + polymorphism”. Furthermore, multiplicity can be formal semiring expressions + combining variables. +- Contrary to the paper, the sum of two multiplicities is always `Many`. This + will have to change, however, if we want to add a multiplicity for 0. Whether + we want to is still debated. +- Case expressions have a multiplicity annotation too. A case expression with + multiplicity `One`, consumes its scrutinee exactly once (provided the entire + case expression is consumed exactly once); whereas a case expression with + multiplicity `Many` can consume its scrutinee as many time as it wishes (no + matter how much the case expression is consumed). + +Note [Usages] +~~~~~~~~~~~~~ +In the _Linear Haskell_ paper, you'll find typing rules such as these: + + Γ ⊢ f : A #π-> B Δ ⊢ u : A + --------------------------- + Γ + kΔ ⊢ f u : B + +If you read this as a type-checking algorithm going from the bottom up, this +reads as: the algorithm has to find a split of some input context Ξ into an +appropriate Γ and a Δ such as Ξ = Γ + kΔ, *and the multiplicities are chosen to +make f and u typecheck*. + +This could be achieved by letting the typechecking of `f` use exactly the +variable it needs, then passing the remainder, as `Delta` to the typechecking of +u. But what does that mean if `x` is bound with multiplicity `p` (a variable) +and `f` consumes `x` once? `Delta` would have to contain `x` with multiplicity +`p-1`. It's not really clear how to make that works. In summary: bottom-up +multiplicity checking forgoes addition and multiplication in favour of +subtraction and division. And variables make the latter hard. + +The alternative is to read multiplicities from the top down: as an *output* from +the typechecking algorithm, rather than an input. We call these output +multiplicities Usages, to distinguish them from the multiplicities which come, +as input, from the types of functions. Usages are checked for compatibility with +multiplicity annotations using an ordering relation. In other words, the usage +of x in the expression u is the smallest multiplicity which can be ascribed to x +for u to typecheck. + +Usages are usually group in a UsageEnv, as defined in the UsageEnv module. + +So, in our function application example, the typechecking algorithm would +receive usage environements f_ue from the typechecking of f, and u_ue from the +typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and +scaling of usage environment is the pointwise extension of the semiring +operations on multiplicities. + +Note [Zero as a usage] +~~~~~~~~~~~~~~~~~~~~~~ +In the current presentation usages are not exactly multiplicities, because they +can contain 0, and multiplicities can't. + +Why do we need a 0 usage? A function which doesn't use its argument will be +required to annotate it with `Many`: + + \(x # Many) -> 0 + +However, we cannot replace absence with Many when computing usages +compositionally: in + + (x, True) + +We expect x to have usage 1. But when computing the usage of x in True we would +find that x is absent, hence has multiplicity Many. The final multiplicity would +be One+Many = Many. Oops! + +Hence there is a usage Zero for absent variables. Zero is characterised by being +the neutral element to usage addition. + +We may decide to add Zero as a multiplicity in the future. In which case, this +distinction will go away. + +Note [Joining usages] +~~~~~~~~~~~~~~~~~~~~~ +The usage of a variable is defined, in Note [Usages], as the minimum usage which +can be ascribed to a variable. + +So what is the usage of x in + + case … of + { p1 -> u -- usage env: u_ue + ; p2 -> v } -- usage env: v_ue + +It must be the least upper bound, or _join_, of u_ue(x) and v_ue(x). + +So, contrary to a declarative presentation where the correct usage of x can be +conjured out of thin air, we need to be able to compute the join of two +multiplicities. Join is extended pointwise on usage environments. + +Note [Bottom as a usage] +~~~~~~~~~~~~~~~~~~~~~~ +What is the usage of x in + + case … of {} + +Per usual linear logic, as well as the _Linear Haskell_ article, x can have +every multiplicity. + +So we need a minimum usage _bottom_, which is also the neutral element for join. + +In fact, this is not such as nice solution, because it is not clear how to +define sum and multiplication with bottom. We give reasonable definitions, but +they are not complete (they don't respect the semiring laws, and it's possible +to come up with examples of Core transformation which are not well-typed) + +A better solution would probably be to annotate case expressions with a usage +environment, just like they are annotated with a type. Which, probably not +coincidentally, is also primarily for empty cases. + +A side benefit of this approach is that the linter would not need to join +multiplicities, anymore; hence would be closer to the presentation in the +article. That's because it could use the annotation as the multiplicity for each +branch. + +Note [Data constructors are linear by default] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data constructors defined without -XLinearTypes (as well as data constructors +defined with the Haskell 98 in all circumstances) have all their fields linear. + +That is, in + + data Maybe a = Nothing | Just a + +We have + + Just :: a #-> Just a + +The goal is to maximise reuse of types between linear code and traditional +code. This is argued at length in the proposal and the article (links in Note +[Linear Types]). + +Note [Polymorphisation of linear fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The choice in Note [Data constructors are linear by default] has an impact on +backwards compatibility. Consider + + map Just + +We have + + map :: (a -> b) -> f a -> f b + Just :: a #-> Just a + +Types don't match, we should get a type error. But this is legal Haskell 98 +code! Bad! Bad! Bad! + +It could be solved with subtyping, but subtyping doesn't combine well with +polymorphism. + +Instead, we generalise the type of Just, when used as term: + + Just :: forall {p}. a #p-> Just a + +This is solely a concern for higher-order code like this: when called fully +applied linear constructors are more general than constructors with unrestricted +fields. In particular, linear constructors can always be eta-expanded to their +Haskell 98 type. This is explained in the paper (but there, we had a different +strategy to resolve this type mismatch in higher-order code. It turned out to be +insufficient, which is explained in the wiki page as well as the proposal). + +We only generalise linear fields this way: fields with multiplicity Many, or +other multiplicity expressions are exclusive to -XLinearTypes, hence don't have +backward compatibility implications. + +The implementation is described in Note [Linear fields generalization]. + +More details in the proposal. +-} + +{- +Note [Adding new multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To add a new multiplicity, you need to: +* Add the new type with Multiplicity kind +* Update cases in mkMultAdd, mkMultMul, mkMultSup, submult, tcSubMult +* Check supUE function that computes sup of a multiplicity + and Zero +-} + +-- +-- * Core properties of multiplicities +-- + +{- +Note [Mult is type] +~~~~~~~~~~~~~~~~~~~ +Mult is a type alias for Type. + +Mult must contain Type because multiplicity variables are mere type variables +(of kind Multiplicity) in Haskell. So the simplest implementation is to make +Mult be Type. + +Multiplicities can be formed with: +- One: GHC.Types.One (= oneDataCon) +- Many: GHC.Types.Many (= manyDataCon) +- Multiplication: GHC.Types.MultMul (= multMulTyCon) + +So that Mult feels a bit more structured, we provide pattern synonyms and smart +constructors for these. +-} +type Mult = Type + +pattern One :: Mult +pattern One <- (eqType oneDataConTy -> True) + where One = oneDataConTy + +pattern Many :: Mult +pattern Many <- (eqType manyDataConTy -> True) + where Many = manyDataConTy + +isMultMul :: Mult -> Maybe (Mult, Mult) +isMultMul ty | Just (tc, [x, y]) <- splitTyConApp_maybe ty + , tc `hasKey` multMulTyConKey = Just (x, y) + | otherwise = Nothing + +pattern MultMul :: Mult -> Mult -> Mult +pattern MultMul p q <- (isMultMul -> Just (p,q)) + +{- +Note [Overapproximating multiplicities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions mkMultAdd, mkMultMul, mkMultSup perform operations +on multiplicities. They can return overapproximations: their result +is merely guaranteed to be a submultiplicity of the actual value. + +They should be used only when an upper bound is acceptable. +In most cases, they are used in usage environments (UsageEnv); +in usage environments, replacing a usage with a larger one can only +cause more programs to fail to typecheck. + +In future work, instead of approximating we might add type families +and allow users to write types involving operations on multiplicities. +In this case, we could enforce more invariants in Mult, for example, +enforce that that it is in the form of a sum of products, and even +that the sumands and factors are ordered somehow, to have more equalities. +-} + +-- With only two multiplicities One and Many, we can always replace +-- p + q by Many. See Note [Overapproximating multiplicities]. +mkMultAdd :: Mult -> Mult -> Mult +mkMultAdd _ _ = Many + +mkMultMul :: Mult -> Mult -> Mult +mkMultMul One p = p +mkMultMul p One = p +mkMultMul Many _ = Many +mkMultMul _ Many = Many +mkMultMul p q = mkTyConApp multMulTyCon [p, q] + +-- See Note [Joining usages] +-- | @mkMultSup w1 w2@ returns a multiplicity such that @mkMultSup w1 +-- w2 >= w1@ and @mkMultSup w1 w2 >= w2@. See Note [Overapproximating multiplicities]. +mkMultSup :: Mult -> Mult -> Mult +mkMultSup = mkMultMul +-- Note: If you are changing this logic, check 'supUE' in UsageEnv as well. + +-- +-- * Multiplicity ordering +-- + +data IsSubmult = Submult -- Definitely a submult + | Unknown -- Could be a submult, need to ask the typechecker + deriving (Show, Eq) + +instance Outputable IsSubmult where + ppr = text . show + +-- | @submult w1 w2@ check whether a value of multiplicity @w1@ is allowed where a +-- value of multiplicity @w2@ is expected. This is a partial order. + +submult :: Mult -> Mult -> IsSubmult +submult _ Many = Submult +submult One One = Submult +-- The 1 <= p rule +submult One _ = Submult +submult _ _ = Unknown + +-- +-- * Utilities +-- + +-- | A shorthand for data with an attached 'Mult' element (the multiplicity). +data Scaled a = Scaled Mult a + deriving (Data) + +scaledMult :: Scaled a -> Mult +scaledMult (Scaled m _) = m + +scaledThing :: Scaled a -> a +scaledThing (Scaled _ t) = t + +unrestricted, linear, tymult :: a -> Scaled a +unrestricted = Scaled Many +linear = Scaled One + +-- Used for type arguments in core +tymult = Scaled Many + +irrelevantMult :: Scaled a -> a +irrelevantMult = scaledThing + +mkScaled :: Mult -> a -> Scaled a +mkScaled = Scaled + +instance (Outputable a) => Outputable (Scaled a) where + ppr (Scaled _cnt t) = ppr t + -- Do not print the multiplicity here because it tends to be too verbose + +scaledSet :: Scaled a -> b -> Scaled b +scaledSet (Scaled m _) b = Scaled m b + +scaleScaled :: Mult -> Scaled a -> Scaled a +scaleScaled m' (Scaled m t) = Scaled (m' `mkMultMul` m) t + +mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type +mapScaledType f (Scaled m t) = Scaled (f m) (f t) diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 17acd5dbfe..44505ef0b6 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -35,6 +35,7 @@ import GHC.Core.Type as Type import GHC.Core.TyCon ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy ) import GHC.Core.Coercion as Coercion +import GHC.Core.Multiplicity import GHC.Types.Basic import GHC.Types.Unique import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) @@ -125,7 +126,7 @@ typeArity ty = go rec_nts ty' | Just (arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res + = typeOneShot (scaledThing arg) : go rec_nts res | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys @@ -1089,13 +1090,13 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty -- lambda \co:ty. e co. In this case we generate a new variable -- of the coercion type, update the scope, and reduce n by 1. | isTyVar tcv = ((subst', tcv'), n) - | otherwise = (freshEtaId n subst' (varType tcv'), n-1) + | otherwise = (freshEtaId n subst' (varScaledType tcv'), n-1) -- Avoid free vars of the original expression in go n_n n_subst ty' (EtaVar n_tcv : eis) ----------- Function types (t1 -> t2) | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , not (isTypeLevPoly arg_ty) + , not (isTypeLevPoly (scaledThing arg_ty)) -- See Note [Levity polymorphism invariants] in GHC.Core -- See also test case typecheck/should_run/EtaExpandLevPoly @@ -1192,7 +1193,7 @@ etaBodyForJoinPoint need_args body init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) -------------- -freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) +freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id) -- Make a fresh Id, with specified type (after applying substitution) -- It should be "fresh" in the sense that it's not in the in-scope set -- of the TvSubstEnv; and it should itself then be added to the in-scope @@ -1203,9 +1204,9 @@ freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) freshEtaId n subst ty = (subst', eta_id') where - ty' = Type.substTyUnchecked subst ty + Scaled mult' ty' = Type.substScaledTyUnchecked subst ty eta_id' = uniqAway (getTCvInScope subst) $ - mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' -- "OrCoVar" since this can be used to eta-expand -- coercion abstractions subst' = extendTCvInScope subst eta_id' diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index d6f37f6eb5..16a0137a4c 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -16,7 +16,7 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where import GHC.Prelude import GHC.Core.Subst -import GHC.Types.Var ( Var ) +import GHC.Types.Var ( Var, varMultMaybe ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Id ( Id, idType, idHasRules , idInlineActivation, setInlineActivation @@ -33,6 +33,7 @@ import GHC.Types.Basic import GHC.Core.Map import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn ) import Data.List ( mapAccumL ) +import GHC.Core.Multiplicity {- Simple common sub-expression @@ -449,8 +450,34 @@ noCSE id = not (isAlwaysActive (idInlineActivation id)) && -- See Note [CSE for INLINE and NOINLINE] || isAnyInlinePragma (idInlinePragma id) -- See Note [CSE for stable unfoldings] + || not (multiplicityOkForCSE id) || isJoinId id -- See Note [CSE for join points?] + where + -- It doesn't make sense to do CSE for a binding which can't be freely + -- shared or dropped. In particular linear bindings, but this is true for + -- any binding whose multiplicity contains a variable. + -- + -- This shows up, in particular, when performing a substitution + -- + -- CSE[let x # 'One = y in x] + -- ==> let x # 'One = y in CSE[x[x\y]] + -- ==> let x # 'One = y in y + -- + -- Here @x@ doesn't appear in the body, but it is required by linearity! + -- Also @y@ appears shared, while we expect it to be a linear variable. + -- + -- This is usually not a problem with let-binders because they are aliases. + -- But we don't have such luxury for case binders. Still, substitution of + -- the case binder by the scrutinee happens routinely in CSE to discover + -- more CSE opportunities (see Note [CSE for case expressions]). + -- + -- It's alright, though! Because there is never a need to share linear + -- definitions. + multiplicityOkForCSE v = case varMultMaybe v of + Just Many -> True + Just _ -> False + Nothing -> True {- Note [Take care with literal strings] diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 5ae5fa693c..6ca8efce2e 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -46,6 +46,7 @@ import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkI import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Unfold ( exprIsConApp_maybe ) +import GHC.Core.Multiplicity import GHC.Core.FVs import GHC.Core.Type import GHC.Types.Var.Set @@ -549,7 +550,7 @@ litEq is_eq = msum where do_lit_eq platform lit expr = do guard (not (litIsLifted lit)) - return (mkWildCase expr (literalType lit) intPrimTy + return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) where @@ -1557,8 +1558,8 @@ match_inline _ = Nothing match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap - , Just (dictTy, _) <- splitFunTy_maybe fieldTy - , Just dictTc <- tyConAppTyCon_maybe dictTy + , Just (dictTy, _) <- splitFunTy_maybe (scaledThing fieldTy) + , Just dictTc <- tyConAppTyCon_maybe (scaledThing dictTy) , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc = Just $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 29fa61a5fc..e5d9c9a0d9 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -19,6 +19,7 @@ import GHC.Driver.Session import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it import GHC.Core +import GHC.Core.Multiplicity ( scaledThing ) import GHC.Core.Seq ( seqBinds ) import GHC.Utils.Outputable import GHC.Types.Var.Env @@ -358,7 +359,7 @@ forcesRealWorld fam_envs ty | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } <- deepSplitProductType_maybe fam_envs ty , isUnboxedTupleCon dc - = any (\(ty,_) -> ty `eqType` realWorldStatePrimTy) field_tys + = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys | otherwise = False diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index d903185c1d..5aa893e7b6 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module GHC.Core.Opt.Exitify ( exitifyProgram ) where {- @@ -48,6 +50,7 @@ import GHC.Types.Var.Env import GHC.Core.FVs import GHC.Data.FastString import GHC.Core.Type +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Utils.Misc( mapSnd ) import Data.Bifunctor @@ -265,7 +268,7 @@ mkExitJoinId in_scope ty join_arity = do `extendInScopeSet` exit_id_tmpl -- just cosmetics return (uniqAway avoid exit_id_tmpl) where - exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty + exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty `asJoinId` join_arity addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index ff63540ed1..03a84b872c 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -38,6 +38,7 @@ import GHC.Driver.Session import GHC.Utils.Outputable -- import Data.List ( mapAccumL ) import GHC.Types.Basic ( RecFlag(..), isRec ) +import GHC.Core.Multiplicity {- Top-level interface function, @floatInwards@. Note that we do not @@ -201,7 +202,7 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {}) = (piResultTy fun_ty ty, extra_fvs) add_arg (fun_ty, extra_fvs) (arg_fvs, arg) - | noFloatIntoArg arg arg_ty + | noFloatIntoArg arg (irrelevantMult arg_ty) = (res_ty, extra_fvs `unionDVarSet` arg_fvs) | otherwise = (res_ty, extra_fvs) diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index af0e6aa5d6..156cb3df99 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2066,7 +2066,8 @@ occAnalLamOrRhs env binders body env1 = env `addInScope` binders (env_body, binders') = oneShotGroup env1 binders -occAnalAlt :: OccEnv -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt :: OccEnv + -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) occAnalAlt env (con, bndrs, rhs) = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) -> let @@ -2074,7 +2075,6 @@ occAnalAlt env (con, bndrs, rhs) in -- See Note [Binders in case alternatives] (alt_usg, (con, tagged_bndrs, rhs1)) } - {- ************************************************************************ * * diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index beecd424b6..bdd28d6a2f 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -47,9 +47,20 @@ The simplifier tries to get rid of occurrences of x, in favour of wild, in the hope that there will only be one remaining occurrence of x, namely the scrutinee of the case, and we can inline it. + + This can only work if @wild@ is an unrestricted binder. Indeed, even with the + extended typing rule (in the linter) for case expressions, if + case x of wild # 1 { p -> e} + is well-typed, then + case x of wild # 1 { p -> e[wild\x] } + is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@ + at all). In which case, it is, of course, pointless to do the substitution + anyway. So for a linear binder (and really anything which isn't unrestricted), + doing this substitution would either produce ill-typed terms or be the + identity. -} -{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.SetLevels ( @@ -94,6 +105,7 @@ import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique ( hasKey ) import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet ) +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Core.DataCon ( dataConOrigResTy ) import GHC.Builtin.Types @@ -477,6 +489,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere + , Many <- idMult case_bndr -- See Note [Floating linear case] = -- Always float the case if possible -- Unlike lets we don't insist that it escapes a value lambda do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) @@ -548,6 +561,18 @@ Things to note: * We only do this with a single-alternative case +Note [Floating linear case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Linear case can't be floated past case branches: + case u of { p1 -> case[1] v of { C x -> ...x...}; p2 -> ... } +Is well typed, but + case[1] v of { C x -> case u of { p1 -> ...x...; p2 -> ... }} +Will not be, because of how `x` is used in one alternative but not the other. + +It is not easy to float this linear cases precisely, so, instead, we elect, for +the moment, to simply not float linear case. + + Note [Setting levels when floating single-alternative cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Handling level-setting when floating a single-alternative case binding @@ -1579,6 +1604,7 @@ extendCaseBndrEnv :: LevelEnv -> LevelEnv extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) case_bndr (Var scrut_var) + | Many <- varMult case_bndr = le { le_subst = extendSubstWithVar subst case_bndr scrut_var , le_env = add_id id_env (case_bndr, scrut_var) } extendCaseBndrEnv env _ _ = env @@ -1682,7 +1708,7 @@ newPolyBndrs dest_lvl mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id transfer_join_info bndr $ - mkSysLocal (mkFastString str) uniq poly_ty + mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty where str = "poly_" ++ occNameString (getOccName bndr) poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) @@ -1717,7 +1743,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) rhs_ty | otherwise - = mkSysLocal (mkFastString "lvl") uniq rhs_ty + = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty -- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 73f941c332..bf75a9de38 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -54,13 +54,15 @@ import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Types.Basic import GHC.Utils.Monad ( mapAccumLM, liftIO ) import GHC.Types.Var ( isTyCoVar ) -import GHC.Data.Maybe ( orElse ) +import GHC.Data.Maybe ( orElse, fromMaybe ) import Control.Monad import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Error import GHC.Unit.Module ( moduleName, pprModuleName ) +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) @@ -358,8 +360,44 @@ simplJoinBind :: SimplEnv simplJoinBind env cont old_bndr new_bndr rhs rhs_se = do { let rhs_env = rhs_se `setInScopeFromE` env ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } + ; let mult = contHoleScaling cont + arity = fromMaybe (pprPanic "simplJoinBind" (ppr new_bndr)) $ + isJoinIdDetails_maybe (idDetails new_bndr) + new_type = scaleJoinPointType mult arity (varType new_bndr) + new_bndr' = setIdType new_bndr new_type + ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr' rhs' } +{- +Note [Scaling join point arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a join point which is linear in its variable, in some context E: + +E[join j :: a #-> a + j x = x + in case v of + A -> j 'x' + B -> <blah>] + +The simplifier changes to: + +join j :: a #-> a + j x = E[x] +in case v of + A -> j 'x' + B -> E[<blah>] + +If E uses its argument in a nonlinear way (e.g. a case['Many]), then +this is wrong: the join point has to change its type to a -> a. +Otherwise, we'd get a linearity error. + +See also Note [Return type for join points] and Note [Join points and case-of-case]. +-} +scaleJoinPointType :: Mult -> Int -> Type -> Type +scaleJoinPointType mult arity ty | arity == 0 = ty + | otherwise = case splitPiTy ty of + (binder, ty') -> mkPiTy (scaleBinder binder) (scaleJoinPointType mult (arity-1) ty') + where scaleBinder (Anon af t) = Anon af (scaleScaled mult t) + scaleBinder b@(Named _) = b -------------------------- simplNonRecX :: SimplEnv -> InId -- Old binder; not a JoinId @@ -664,7 +702,7 @@ makeTrivialBinding mode top_lvl occ_fs info expr expr_ty = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name expr_ty info + var = mkLocalIdWithInfo name Many expr_ty info -- Now something very like completeBind, -- but without the postInlineUnconditionally part @@ -968,8 +1006,8 @@ simplExprF env e cont simplExprF1 :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplExprF1 _ (Type ty) _ - = pprPanic "simplExprF: type" (ppr ty) +simplExprF1 _ (Type ty) cont + = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) -- simplExprF does only with term-valued expressions -- The (Type ty) case is handled separately by simplExpr -- and by the other callers of simplExprF @@ -996,10 +1034,14 @@ simplExprF1 env (App fun arg) cont ApplyToTy { sc_arg_ty = arg' , sc_hole_ty = hole' , sc_cont = cont } } - _ -> simplExprF env fun $ + _ -> + let fun_ty = exprType fun + (Scaled m _, _) = splitFunTy fun_ty + in + simplExprF env fun $ ApplyToVal { sc_arg = arg, sc_env = env , sc_hole_ty = substTy env (exprType fun) - , sc_dup = NoDup, sc_cont = cont } + , sc_dup = NoDup, sc_cont = cont, sc_mult = m } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} @@ -1105,7 +1147,8 @@ simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont simplJoinRhs env bndr expr cont | Just arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders arity expr - ; (env', join_bndrs') <- simplLamBndrs env join_bndrs + mult = contHoleScaling cont + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleIdBy mult) join_bndrs) ; join_body' <- simplExprC env' join_body cont ; return $ mkLams join_bndrs' join_body' } @@ -1303,8 +1346,8 @@ rebuild env expr cont Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } - -> rebuildCall env (addValArgTo fun expr fun_ty ) cont + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m } + -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body , sc_env = se, sc_cont = cont } -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr @@ -1396,7 +1439,7 @@ simplCast env body co0 cont0 -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail }) + , sc_dup = dup, sc_cont = tail, sc_mult = m }) | Just (co1, m_co2) <- pushCoValArg co , let new_ty = coercionRKind co1 , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg @@ -1419,7 +1462,8 @@ simplCast env body co0 cont0 , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } + , sc_hole_ty = coercionLKind co + , sc_mult = m }) } } addCoerce co cont | isReflexiveCo co = return cont -- Having this at the end makes a huge @@ -1953,16 +1997,17 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o -- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) - (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m }) | fun `hasKey` runRWKey , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args - = do { s <- newId (fsLit "s") realWorldStatePrimTy + = do { s <- newId (fsLit "s") Many realWorldStatePrimTy ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] ty' = contResultType cont cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy realWorldStatePrimTy ty' } + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' + , sc_mult = m } -- cont' applies to s, then K ; body' <- simplExprC env' arg cont' ; let arg' = Lam s body' @@ -1974,10 +2019,10 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup_flag, sc_hole_ty = fun_ty - , sc_cont = cont }) + , sc_cont = cont, sc_mult = m }) -- Argument is already simplified | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo info' arg fun_ty) cont + = rebuildCall env (addValArgTo info' (m, arg) fun_ty) cont -- Strict arguments | str @@ -1986,7 +2031,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules simplExprF (arg_se `setInScopeFromE` env) arg (StrictArg { sc_fun = info', sc_cci = cci_strict , sc_dup = Simplified, sc_fun_ty = fun_ty - , sc_cont = cont }) + , sc_cont = cont, sc_mult = m }) -- Note [Shadowing] -- Lazy arguments @@ -1997,7 +2042,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg (mkLazyArgStop arg_ty cci_lazy) - ; rebuildCall env (addValArgTo info' arg' fun_ty) cont } + ; rebuildCall env (addValArgTo info' (m, arg') fun_ty) cont } where info' = info { ai_strs = strs, ai_discs = discs } arg_ty = funArgTy fun_ty @@ -2219,10 +2264,25 @@ trySeqRules in_env scrut rhs cont , TyArg { as_arg_ty = rhs_ty , as_hole_ty = res2_ty } , ValArg { as_arg = no_cast_scrut - , as_hole_ty = res3_ty } ] + , as_hole_ty = res3_ty + , as_mult = Many } ] + -- The multiplicity of the scrutiny above is Many because the type + -- of seq requires that its first argument is unrestricted. The + -- typing rule of case also guarantees it though. In a more + -- general world, where the first argument of seq would have + -- affine multiplicity, then we could use the multiplicity of + -- the case (held in the case binder) instead. rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs , sc_env = in_env, sc_cont = cont - , sc_hole_ty = res4_ty } + , sc_hole_ty = res4_ty, sc_mult = Many } + -- The multiplicity in sc_mult above is the + -- multiplicity of the second argument of seq. Since + -- seq's type, as it stands, imposes that its second + -- argument be unrestricted, so is + -- sc_mult. However, a more precise typing rule, + -- for seq, would be to have it be linear. In which + -- case, sc_mult should be 1. + -- Lazily evaluated, so we don't do most of this drop_casts (Cast e _) = drop_casts e @@ -2575,13 +2635,14 @@ rebuildCase env scrut case_bndr alts cont -- as well as when it's an explicit constructor application , let env0 = setInScopeSet env in_scope' = do { tick (KnownBranch case_bndr) + ; let scaled_wfloats = map scale_float wfloats ; case findAlt (DataAlt con) alts of Nothing -> missingAlt env0 case_bndr alts cont Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) `mkTyApps` ty_args `mkApps` other_args - in simple_rhs env0 wfloats con_app bs rhs - Just (_, bs, rhs) -> knownCon env0 scrut wfloats con ty_args other_args + in simple_rhs env0 scaled_wfloats con_app bs rhs + Just (_, bs, rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args case_bndr bs rhs cont } where @@ -2599,6 +2660,31 @@ rebuildCase env scrut case_bndr alts cont GHC.Core.Make.wrapFloats wfloats $ wrapFloats (floats1 `addFloats` floats2) expr' )} + -- This scales case floats by the multiplicity of the continuation hole (see + -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because + -- they are aliases anyway. + scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = + let + scale_id id = scaleIdBy holeScaling id + in + GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float f = f + + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr + -- We are in the following situation + -- case[p] case[q] u of { D x -> C v } of { C x -> w } + -- And we are producing case[??] u of { D x -> w[x\v]} + -- + -- What should the multiplicity `??` be? In order to preserve the usage of + -- variables in `u`, it needs to be `pq`. + -- + -- As an illustration, consider the following + -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } + -- Where C :: A #-> T is linear + -- If we were to produce a case[1], like the inner case, we would get + -- case[1] of { C x -> (x, x) } + -- Which is ill-typed with respect to linearity. So it needs to be a + -- case[Many]. -------------------------------------------------- -- 2. Eliminate the case if scrutinee is evaluated @@ -2680,8 +2766,11 @@ reallyRebuildCase env scrut case_bndr alts cont | otherwise = do { (floats, cont') <- mkDupableCaseCont env alts cont ; case_expr <- simplAlts (env `setInScopeFromF` floats) - scrut case_bndr alts cont' + scrut (scaleIdBy holeScaling case_bndr) (scaleAltsBy holeScaling alts) cont' ; return (floats, case_expr) } + where + holeScaling = contHoleScaling cont + -- Note [Scaling in case-of-case] {- simplCaseBinder checks whether the scrutinee is a variable, v. If so, @@ -2760,6 +2849,39 @@ taking advantage of the `seq`. At one point I did transformation in LiberateCase, but it's more robust here. (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before LiberateCase gets to see it.) + +Note [Scaling in case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When two cases commute, if done naively, the multiplicities will be wrong: + + case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] + { (z[Many], t[Many]) -> z + } + +The multiplicities here, are correct, but if I perform a case of case: + + case u of w[1] + { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and +`y` must have multiplicities `Many` not `1`! The correct solution is to make +all the `1`-s be `Many`-s instead: + + case u of w[Many] + { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +In general, when commuting two cases, the rule has to be: + + case (case … of x[p] {…}) of y[q] { … } + ===> case … of x[p*q] { … case … of y[q] { … } } + +This is materialised, in the simplifier, by the fact that every time we simplify +case alternatives with a continuation (the surrounded case (or more!)), we must +scale the entire case we are simplifying, by a scaling factor which can be +computed in the continuation (with function `contHoleScaling`). -} simplAlts :: SimplEnv @@ -2802,7 +2924,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -- Note [Improving seq] improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 + = do { case_bndr2 <- newId (fsLit "nt") Many ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } @@ -2924,11 +3046,12 @@ addAltUnfoldings env scrut case_bndr con_app env1 = addBinderUnfolding env case_bndr con_app_unf -- See Note [Add unfolding for scrutinee] - env2 = case scrut of + env2 | Many <- idMult case_bndr = case scrut of Just (Var v) -> addBinderUnfolding env1 v con_app_unf Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ mk_simple_unf (Cast con_app (mkSymCo co)) _ -> env1 + | otherwise = env1 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 } @@ -3003,6 +3126,9 @@ piece of information. So instead we add the unfolding x -> Just a, and x -> Nothing in the respective RHSs. +Since this transformation is tantamount to a binder swap, the same caveat as in +Note [Suppressing binder-swaps on linear case] in OccurAnal apply. + ************************************************************************ * * @@ -3213,7 +3339,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs , sc_cont = mkBoringStop res_ty } ) } mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci - , sc_cont = cont, sc_fun_ty = fun_ty }) + , sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }) -- See Note [Duplicating StrictArg] -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable = do { (floats1, cont') <- mkDupableCont env cont @@ -3224,6 +3350,7 @@ mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci , sc_cont = cont' , sc_cci = cci , sc_fun_ty = fun_ty + , sc_mult = m , sc_dup = OkToDup} ) } mkDupableCont env (ApplyToTy { sc_cont = cont @@ -3234,7 +3361,7 @@ mkDupableCont env (ApplyToTy { sc_cont = cont mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup , sc_env = se, sc_cont = cont - , sc_hole_ty = hole_ty }) + , sc_hole_ty = hole_ty, sc_mult = mult }) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg... @@ -3253,7 +3380,7 @@ mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup -- has turned arg'' into a fresh variable -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_dup = OkToDup, sc_cont = cont' - , sc_hole_ty = hole_ty }) } + , sc_hole_ty = hole_ty, sc_mult = mult }) } mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts , sc_env = se, sc_cont = cont }) @@ -3269,8 +3396,10 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts -- And this is important: see Note [Fusing case continuations] ; let alt_env = se `setInScopeFromF` floats - ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts + ; let cont_scaling = contHoleScaling cont + -- See Note [Scaling in case-of-case] + ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts) -- Safe to say that there are no handled-cons for the DEFAULT case -- NB: simplBinder does not zap deadness occ-info, so -- a dead case_bndr' will still advertise its deadness diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 4a749e8951..5c8e0f21c2 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -63,6 +63,7 @@ import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Core.Multiplicity import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable @@ -276,7 +277,7 @@ mkSimplEnv mode -- The top level "enclosing CC" is "SUBSUMED". init_in_scope :: InScopeSet -init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy)) -- See Note [WildCard binders] {- @@ -724,6 +725,8 @@ changed!! That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr takes a (Just res_ty) argument so that it knows to do the type-changing thing. + +See also Note [Scaling join point arguments]. -} simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) @@ -927,12 +930,15 @@ substCo env co = Coercion.substCo (getTCvSubst env) co ------------------ substIdType :: SimplEnv -> Id -> Id substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) - || noFreeVarsOfType old_ty + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || no_free_vars = id - | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) + | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself where + no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w + subst = TCvSubst in_scope tv_env cv_env old_ty = idType id + old_w = varMult id diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index d0096e1a7e..b84ed1028f 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} {- (c) The AQUA Project, Glasgow University, 1993-1998 @@ -26,7 +27,7 @@ import GHC.Types.Var ( Var, isId, mkLocalVar ) import GHC.Types.Name ( mkSystemVarName ) import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) -import GHC.Core.Type ( Type, mkLamTypes ) +import GHC.Core.Type ( Type, mkLamTypes, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Core ( RuleEnv(..) ) import GHC.Types.Unique.Supply @@ -40,6 +41,7 @@ import GHC.Utils.Misc ( count ) import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) +import GHC.Core.Multiplicity ( pattern Many ) {- ************************************************************************ @@ -180,9 +182,9 @@ getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) -newId :: FastString -> Type -> SimplM Id -newId fs ty = do uniq <- getUniqueM - return (mkSysLocalOrCoVar fs uniq ty) +newId :: FastString -> Mult -> Type -> SimplM Id +newId fs w ty = do uniq <- getUniqueM + return (mkSysLocalOrCoVar fs uniq w ty) newJoinId :: [Var] -> Type -> SimplM Id newJoinId bndrs body_ty @@ -196,7 +198,7 @@ newJoinId bndrs body_ty id_info = vanillaIdInfo `setArityInfo` arity -- `setOccInfo` strongLoopBreaker - ; return (mkLocalVar details name join_id_ty id_info) } + ; return (mkLocalVar details name Many join_id_ty id_info) } {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 5878445d44..c1cb4c9f3f 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -19,7 +19,7 @@ module GHC.Core.Opt.Simplify.Utils ( -- The continuation type SimplCont(..), DupFlag(..), StaticEnv, isSimplified, contIsStop, - contIsDupable, contResultType, contHoleType, + contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, @@ -62,6 +62,7 @@ import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Core.Multiplicity import GHC.Utils.Misc import GHC.Data.OrdList ( isNilOL ) import GHC.Utils.Monad @@ -123,7 +124,8 @@ data SimplCont -- See Note [The hole type in ApplyToTy/Val] , sc_arg :: InExpr -- The argument, , sc_env :: StaticEnv -- see Note [StaticEnv invariant] - , sc_cont :: SimplCont } + , sc_cont :: SimplCont + , sc_mult :: Mult } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] { sc_arg_ty :: OutType -- Argument type @@ -156,7 +158,8 @@ data SimplCont , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), -- presumably (arg_ty -> res_ty) -- where res_ty is expected by sc_cont - , sc_cont :: SimplCont } + , sc_cont :: SimplCont + , sc_mult :: Mult } | TickIt -- (TickIt t K)[e] = K[ tick t e ] (Tickish Id) -- Tick tickish <hole> @@ -274,22 +277,23 @@ data ArgInfo } data ArgSpec - = ValArg { as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal + = ValArg { as_mult :: Mult + , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) | CastBy OutCoercion -- Cast by this; c.f. CastIt instance Outputable ArgSpec where - ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg + ppr (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty ppr (CastBy c) = text "CastBy" <+> ppr c -addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo -addValArgTo ai arg hole_ty = ai { ai_args = arg_spec : ai_args ai - , ai_rules = decRules (ai_rules ai) } +addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo +addValArgTo ai (w, arg) hole_ty = ai { ai_args = arg_spec : ai_args ai + , ai_rules = decRules (ai_rules ai) } where - arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty } + arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w } addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai @@ -312,9 +316,9 @@ pushSimplifiedArgs env (arg : args) k = case arg of TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } - ValArg { as_arg = arg, as_hole_ty = hole_ty } + ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w } -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified - , sc_hole_ty = hole_ty, sc_cont = rest } + , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w } CastBy c -> CastIt c rest where rest = pushSimplifiedArgs env args k @@ -413,12 +417,33 @@ contHoleType (TickIt _ k) = contHoleType k contHoleType (CastIt co _) = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) = perhapsSubstTy dup se (idType b) -contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty -contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val] +contHoleType (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val] contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) = perhapsSubstTy d se (idType b) + +-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of +-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling +-- factor is p. And in E[G[]], the scaling factor is the product of the scaling +-- factor of E and that of G. +-- +-- The scaling factor at the hole of E[] is used to determine how a binder +-- should be scaled if it commutes with E. This appears, in particular, in the +-- case-of-case transformation. +contHoleScaling :: SimplCont -> Mult +contHoleScaling (Stop _ _) = One +contHoleScaling (CastIt _ k) = contHoleScaling k +contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) = + (idMult id) `mkMultMul` contHoleScaling k +contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) = + w `mkMultMul` contHoleScaling k +contHoleScaling (Select { sc_bndr = id, sc_cont = k }) = + (idMult id) `mkMultMul` contHoleScaling k +contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k +contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k +contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- countArgs :: SimplCont -> Int -- Count all arguments, including types, coercions, and other values @@ -521,7 +546,7 @@ mkArgInfo env fun rules n_val_args call_cont add_type_str _ [] = [] add_type_str fun_ty all_strs@(str:strs) - | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info + | Just (Scaled _ arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info = (str || Just False == isLiftedType_maybe arg_ty) : add_type_str fun_ty' strs -- If the type is levity-polymorphic, we can't know whether it's @@ -1831,7 +1856,7 @@ abstractFloats dflags top_lvl main_tvs floats body ; let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id - mkLocalId poly_name poly_ty + mkLocalId poly_name (idMult var) poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } -- In the olden days, it was crucial to copy the occInfo of the original var, -- because we were looking at occurrence-analysed but as yet unsimplified code! @@ -1953,7 +1978,10 @@ prepareAlts scrut case_bndr' alts -- Test simpl013 is an example = do { us <- getUniquesM ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts - (yes2, alts2) = refineDefaultAlt us tc tys idcs1 alts1 + (yes2, alts2) = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1 + -- the multiplicity on case_bndr's is the multiplicity of the + -- case expression The newly introduced patterns in + -- refineDefaultAlt must be scaled by this multiplicity (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 -- "idcs" stands for "impossible default data constructors" -- i.e. the constructors that can't match the default case @@ -2184,7 +2212,7 @@ mkCase2 dflags scrut bndr alts_ty alts _ -> True , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut - = do { bndr' <- newId (fsLit "lwild") (exprType scrut') + = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts -- mapMaybeM: discard unreachable alternatives @@ -2235,7 +2263,7 @@ mkCase2 dflags scrut bndr alts_ty alts = -- For non-nullary data cons we must invent some fake binders -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold do { us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc + ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc (tyConAppArgs (idType new_bndr)) ; return (ex_tvs ++ arg_ids) } mk_new_bndrs _ _ = return [] diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index da8aaa3447..c3135de28f 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -32,6 +32,7 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon ( tyConName ) +import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr ) import GHC.Core.Make ( mkImpossibleExpr ) @@ -969,7 +970,7 @@ forceSpecBndr :: ScEnv -> Var -> Bool forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var forceSpecFunTy :: ScEnv -> Type -> Bool -forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys +forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys forceSpecArgTy :: ScEnv -> Type -> Bool forceSpecArgTy env ty @@ -1675,7 +1676,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) spec_join_arity | isJoinId fn = Just (length spec_lam_args) | otherwise = Nothing - spec_id = mkLocalId spec_name + spec_id = mkLocalId spec_name Many (mkLamTypes spec_lam_args body_ty) -- See Note [Transfer strictness] `setIdStrictness` spec_str @@ -2052,7 +2053,7 @@ callToPats env bndr_occs call@(Call _ args con_env) -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable - sanitise id = id `setIdType` expandTypeSynonyms (idType id) + sanitise id = updateIdTypeAndMult expandTypeSynonyms id -- See Note [Free type variables of the qvar types] -- Bad coercion variables: see Note [SpecConstr and casts] @@ -2212,7 +2213,7 @@ argToPat _env _in_scope _val_env arg _arg_occ wildCardPat :: Type -> UniqSM (Bool, CoreArg) wildCardPat ty = do { uniq <- getUniqueM - ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty + ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty ; return (False, varToCoreExpr id) } argsToPats :: ScEnv -> InScopeSet -> ValueEnv diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 44cfc460dd..ae3d1cb287 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} @@ -18,6 +19,7 @@ import GHC.Prelude import GHC.Types.Id import GHC.Tc.Utils.TcType hiding( substTy ) import GHC.Core.Type hiding( substTy, extendTvSubstList ) +import GHC.Core.Multiplicity import GHC.Core.Predicate import GHC.Unit.Module( Module, HasModule(..) ) import GHC.Core.Coercion( Coercion ) @@ -1130,9 +1132,10 @@ specCase env scrut' case_bndr [(con, args, rhs)] sc_args' = filter is_flt_sc_arg args' clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocalOrCoVar occ uniq ty loc) } + ; return (mkUserLocalOrCoVar occ uniq wght ty loc) } where name = idName bndr + wght = idMult bndr ty = idType bndr occ = nameOccName name loc = getSrcSpan name @@ -1423,7 +1426,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs (spec_bndrs, spec_rhs, spec_fn_ty) | add_void_arg = ( voidPrimId : spec_bndrs1 , Lam voidArgId spec_rhs1 - , mkVisFunTy voidPrimTy spec_fn_ty1) + , mkVisFunTyMany voidPrimTy spec_fn_ty1) | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) join_arity_decr = length rule_lhs_args - length spec_bndrs @@ -2504,7 +2507,7 @@ mkCallUDs' env f args -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg mk_spec_arg arg (Anon InvisArg pred) - | type_determines_value pred + | type_determines_value (scaledThing pred) , interestingDict env arg -- Note [Interesting dictionary arguments] = SpecDict arg | otherwise = UnspecArg @@ -2890,7 +2893,7 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr newDictBndr env b = do { uniq <- getUniqueM ; let n = idName b ty' = substTy env (idType b) - ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } + ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id -- Give the new Id a similar occurrence name to the old one @@ -2898,7 +2901,7 @@ newSpecIdSM old_id new_ty join_arity_maybe = do { uniq <- getUniqueM ; let name = idName old_id new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + new_id = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name) `asJoinId_maybe` join_arity_maybe ; return new_id } diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index 827a3e90a5..dd015924e3 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -48,7 +48,7 @@ The previous patch, to fix polymorphic floatout demand signatures, is essential to make this work well! -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, PatternSynonyms #-} module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where import GHC.Prelude @@ -56,6 +56,7 @@ import GHC.Prelude import GHC.Types.Var import GHC.Core import GHC.Core.Utils +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core.Type import GHC.Core.Coercion import GHC.Types.Id @@ -420,12 +421,13 @@ saTransform binder arg_staticness rhs_binders rhs_body shadow_rhs = mkLams shadow_lam_bndrs local_body -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs - rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body) + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq Many (exprType rec_body) -- rec_body_bndr = sat_worker -- See Note [Shadow binding]; make a SysLocal shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) (idUnique binder) + Many (exprType shadow_rhs) isStaticValue :: Staticness App -> Bool diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 4c4a5ced8a..9da3065bed 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -34,6 +34,7 @@ import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred ) import GHC.Types.RepType ( isVoidTy, typePrimRep ) import GHC.Core.Coercion @@ -185,7 +186,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info -- Note [Do not split void functions] only_one_void_argument | [d] <- demands - , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty + , Just (Scaled _ arg_ty1, _) <- splitFunTy_maybe fun_ty , isAbsDmd d && isVoidTy arg_ty1 = True | otherwise @@ -423,7 +424,7 @@ mkWWargs subst fun_ty demands | (dmd:demands') <- demands , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty = do { uniq <- getUniqueM - ; let arg_ty' = substTy subst arg_ty + ; let arg_ty' = substScaledTy subst arg_ty id = mk_wrap_arg uniq arg_ty' dmd ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs subst fun_ty' demands' @@ -472,9 +473,9 @@ mkWWargs subst fun_ty demands applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars -mk_wrap_arg :: Unique -> Type -> Demand -> Id -mk_wrap_arg uniq ty dmd - = mkSysLocalOrCoVar (fsLit "w") uniq ty +mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id +mk_wrap_arg uniq (Scaled w ty) dmd + = mkSysLocalOrCoVar (fsLit "w") uniq w ty `setIdDemandInfo` dmd {- Note [Freshen WW arguments] @@ -635,10 +636,12 @@ unbox_one dflags fam_envs arg cs , dcac_arg_tys = inst_con_arg_tys , dcac_co = co } = do { (uniq1:uniqs) <- getUniquesM - ; let -- See Note [Add demands for strict constructors] + ; let scale = scaleScaled (idMult arg) + scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys + -- See Note [Add demands for strict constructors] cs' = addDataConStrictness data_con cs - unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs' - unbox_fn = mkUnpackCase (Var arg) co uniq1 + unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs' + unbox_fn = mkUnpackCase (Var arg) co (idMult arg) uniq1 data_con unpk_args arg_no_unf = zapStableUnfolding arg -- See Note [Zap unfolding when beta-reducing] @@ -949,7 +952,7 @@ data DataConAppContext = DataConAppContext { dcac_dc :: !DataCon , dcac_tys :: ![Type] - , dcac_arg_tys :: ![(Type, StrictnessMark)] + , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)] , dcac_co :: !Coercion } @@ -990,12 +993,22 @@ deepSplitCprType_maybe fam_envs con_tag ty , let con = cons `getNth` (con_tag - fIRST_TAG) arg_tys = dataConInstArgTys con tc_args strict_marks = dataConRepStrictness con + , all isLinear arg_tys + -- Deactivates CPR worker/wrapper splits on constructors with non-linear + -- arguments, for the moment, because they require unboxed tuple with variable + -- multiplicity fields. = Just DataConAppContext { dcac_dc = con , dcac_tys = tc_args , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks , dcac_co = co } deepSplitCprType_maybe _ _ _ = Nothing +isLinear :: Scaled a -> Bool +isLinear (Scaled w _ ) = + case w of + One -> True + _ -> False + findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand @@ -1018,7 +1031,7 @@ findTypeShape fam_envs ty else checkRecTc rec_tc tc -- We treat tuples specially because they can't cause loops. -- Maybe we should do so in checkRecTc. - = TsProd (map (go rec_tc) (dataConInstArgTys con tc_args)) + = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args)) | Just (_, ty') <- splitForAllTy_maybe ty = go rec_tc ty' @@ -1075,8 +1088,9 @@ mkWWcpr_help :: DataConAppContext mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys , dcac_arg_tys = arg_tys, dcac_co = co }) | [arg1@(arg_ty1, _)] <- arg_tys - , isUnliftedType arg_ty1 - -- Special case when there is a single result of unlifted type + , isUnliftedType (scaledThing arg_ty1) + , isLinear arg_ty1 + -- Special case when there is a single result of unlifted, linear, type -- -- Wrapper: case (..call worker..) of x -> C x -- Worker: case ( ..body.. ) of C x -> x @@ -1086,42 +1100,50 @@ mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys ; return ( True , \ wkr_call -> mkDefaultCase wkr_call arg con_app - , \ body -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg) + , \ body -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg) -- varToCoreExpr important here: arg can be a coercion -- Lacking this caused #10658 - , arg_ty1 ) } + , scaledThing arg_ty1 ) } | otherwise -- The general case -- Wrapper: case (..call worker..) of (# a, b #) -> C a b -- Worker: case ( ...body... ) of C a b -> (# a, b #) + -- + -- Remark on linearity: in both the case of the wrapper and the worker, + -- we build a linear case. All the multiplicity information is kept in + -- the constructors (both C and (#, #)). In particular (#,#) is + -- parametrised by the multiplicity of its fields. Specifically, in this + -- instance, the multiplicity of the fields of (#,#) is chosen to be the + -- same as those of C. = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM - ; let wrap_wild = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict) + ; let wrap_wild = mk_ww_local wild_uniq (linear ubx_tup_ty,MarkedStrict) args = zipWith mk_ww_local uniqs arg_tys ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args) + ubx_tup_app = mkCoreUbxTup (map (scaledThing . fst) arg_tys) (map varToCoreExpr args) con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co tup_con = tupleDataCon Unboxed (length arg_tys) ; return (True , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild (DataAlt tup_con) args con_app - , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app + , \ body -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app , ubx_tup_ty ) } -mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr +mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr -- (mkUnpackCase e co uniq Con args body) -- returns -- case e |> co of bndr { Con args -> body } -mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking] - = Tick tickish (mkUnpackCase e co uniq con args body) -mkUnpackCase scrut co uniq boxing_con unpk_args body +mkUnpackCase (Tick tickish e) co mult uniq con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co mult uniq con args body) +mkUnpackCase scrut co mult uniq boxing_con unpk_args body = mkSingleAltCase casted_scrut bndr (DataAlt boxing_con) unpk_args body where casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict) - + bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict) + -- An unpacking case can always be chosen linear, because the variables + -- are always passed to a constructor. This limits the {- Note [non-algebraic or open body type warning] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1257,10 +1279,10 @@ mk_absent_let dflags fam_envs arg -- See also Note [Unique Determinism] in GHC.Types.Unique unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] -mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id +mk_ww_local :: Unique -> (Scaled Type, StrictnessMark) -> Id -- The StrictnessMark comes form the data constructor and says -- whether this field is strict -- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq (ty,str) +mk_ww_local uniq (Scaled w ty,str) = setCaseBndrEvald str $ - mkSysLocalOrCoVar (fsLit "ww") uniq ty + mkSysLocalOrCoVar (fsLit "ww") uniq w ty diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index c518a6c94e..6f88fd897d 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -33,6 +33,7 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Utils.Misc +import GHC.Core.Multiplicity import GHC.Types.Basic import GHC.Types.Var import GHC.Types.FieldLabel @@ -421,13 +422,13 @@ patSynExTyVars ps = binderVars (psExTyVars ps) patSynExTyVarBinders :: PatSyn -> [InvisTVBinder] patSynExTyVarBinders = psExTyVars -patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type) +patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) patSynSigBndr (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs - , psProvTheta = prov, psReqTheta = req - , psArgs = arg_tys, psResultTy = res_ty }) - = (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psResultTy = res_ty }) + = (univ_tvs, req, ex_tvs, prov, map unrestricted arg_tys, res_ty) -patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Scaled Type], Type) patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty) @@ -484,6 +485,6 @@ pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , pprType sigma_ty ] where sigma_ty = mkInvisForAllTys ex_tvs $ - mkInvisFunTys prov_theta $ - mkVisFunTys orig_args orig_res_ty + mkInvisFunTysMany prov_theta $ + mkVisFunTysMany orig_args orig_res_ty insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs index 628d13ad7f..873c6ac199 100644 --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -166,7 +166,7 @@ pprTyThing :: ShowSub -> TyThing -> SDoc -- We pretty-print 'TyThing' via 'IfaceDecl' -- See Note [Pretty-printing TyThings] pprTyThing ss ty_thing - = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing) + = sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags ty_thing)) where ss' = case ss_how_much ss of ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs index 9f0eefef30..dda9e24db2 100644 --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -41,6 +41,7 @@ import GHC.Builtin.Names import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Core.Multiplicity ( scaledThing ) import Control.Monad ( guard ) @@ -70,7 +71,7 @@ classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of _ | (tvs, rho) <- splitForAllTys ev_ty , (theta, pred) <- splitFunTys rho , not (null tvs && null theta) - -> ForAllPred tvs theta pred + -> ForAllPred tvs (map scaledThing theta) pred | otherwise -> IrredPred ev_ty diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 216c30d8fc..b0b6416c0b 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -45,6 +45,7 @@ import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSub , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Core.TyCon ( tyConArity ) +import GHC.Core.Multiplicity import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic @@ -377,7 +378,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) top_level | Type ty <- in_rhs -- let a::* = TYPE ty in <body> , let out_ty = substTy (soe_subst rhs_env) ty - = ASSERT( isTyVar in_bndr ) + = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs ) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs @@ -435,7 +436,7 @@ simple_out_bind :: TopLevelFlag -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) | Type out_ty <- out_rhs - = ASSERT( isTyVar in_bndr ) + = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr out_rhs ) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion out_co <- out_rhs @@ -588,7 +589,7 @@ subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id Subst in_scope id_subst tv_subst cv_subst = subst id1 = uniqAway in_scope old_id - id2 = setIdType id1 (substTy subst (idType old_id)) + id2 = updateIdTypeAndMult (substTy subst) id1 new_id = zapFragileIdInfo id2 -- Zaps rules, unfolding, and fragile OccInfo -- The unfolding and rules will get added back later, by add_info @@ -1399,7 +1400,14 @@ pushCoValArg co = Just (mkRepReflCo arg, MRefl) | isFunTy tyL - , (co1, co2) <- decomposeFunCo Representational co + , (co_mult, co1, co2) <- decomposeFunCo Representational co + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't reflexivity: + -- it could be an unsafe axiom, and losing this information could yield + -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) + -- with co :: (Int -> ()) ~ (Int #-> ()), would reduce to (fun x ::(1) Int + -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) -- then co1 :: tyL1 ~ tyR1 -- co2 :: tyL2 ~ tyR2 @@ -1422,11 +1430,15 @@ pushCoercionIntoLambda in_scope x e co | ASSERT(not (isTyVar x) && not (isCoVar x)) True , Pair s1s2 t1t2 <- coercionKind co , Just (_s1,_s2) <- splitFunTy_maybe s1s2 - , Just (t1,_t2) <- splitFunTy_maybe t1t2 - = let (co1, co2) = decomposeFunCo Representational co + , Just (Scaled w1 t1,_t2) <- splitFunTy_maybe t1t2 + , (co_mult, co1, co2) <- decomposeFunCo Representational co + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't + -- reflexivity. See pushCoValArg for more details. + = let -- Should we optimize the coercions here? -- Otherwise they might not match too well - x' = x `setIdType` t1 + x' = x `setIdType` t1 `setIdMult` w1 in_scope' = in_scope `extendInScopeSet` x' subst = extendIdSubst (mkEmptySubst in_scope') x @@ -1478,14 +1490,15 @@ pushCoDataCon dc dc_args co (map exprToType ex_args) -- Cast the value arguments (which include dictionaries) - new_val_args = zipWith cast_arg arg_tys val_args + new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) to_ex_args = map Type to_ex_arg_tys dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, ppr arg_tys, ppr dc_args, - ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] + ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc + , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] in ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) @@ -1545,7 +1558,8 @@ collectBindersPushingCo e | isId b , let Pair tyL tyR = coercionKind co , ASSERT( isFunTy tyL) isFunTy tyR - , (co_arg, co_res) <- decomposeFunCo Representational co + , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co + , isReflCo co_mult -- See Note [collectBindersPushingCo] , isReflCo co_arg -- See Note [collectBindersPushingCo] = go_c (b:bs) e co_res @@ -1556,7 +1570,7 @@ collectBindersPushingCo e Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form - <type> -> blah + <type> # w -> blah (and similarly for foralls) to keep this function simple. We could do more elaborate stuff, but it'd involve substitution etc. diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index ddb5b61f7b..f2b25e17e5 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -476,11 +476,12 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 - | otherwise = setIdType id1 (substTy subst old_ty) + | otherwise = updateIdTypeAndMult (substTy subst) id1 old_ty = idType old_id + old_w = idMult old_id no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || - noFreeVarsOfType old_ty + (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with @@ -600,13 +601,16 @@ substCo subst co = Coercion.substCo (getTCvSubst subst) co substIdType :: Subst -> Id -> Id substIdType subst@(Subst _ _ tv_env cv_env) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id - | otherwise = setIdType id (substTy subst old_ty) - -- The tyCoVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id + | otherwise = + updateIdTypeAndMult (substTy subst) id + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself where old_ty = idType id + old_w = varMult id ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index c31b58f6ed..246da2be54 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -149,8 +149,9 @@ tidyIdBndr env@(tidy_env, var_env) id -- though we could extract it from the Id -- ty' = tidyType env (idType id) + mult' = tidyType env (idMult id) name' = mkInternalName (idUnique id) occ' noSrcSpan - id' = mkLocalIdWithInfo name' ty' new_info + id' = mkLocalIdWithInfo name' mult' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo] @@ -174,9 +175,10 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let ty' = tidyType env (idType id) + mult' = tidyType env (idMult id) name' = mkInternalName (idUnique id) occ' noSrcSpan details = idDetails id - id' = mkLocalVar details name' ty' new_info + id' = mkLocalVar details name' mult' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo] diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index e6083eb521..0d7e1cb47c 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -570,7 +570,7 @@ tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc -tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc @@ -617,8 +617,8 @@ tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc -tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc - = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (FunCo _ w co1 co2) fv_cand in_scope acc + = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc @@ -672,8 +672,9 @@ almost_devoid_co_var_of_co (AppCo co arg) cv almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv = almost_devoid_co_var_of_co kind_co cv && (v == cv || almost_devoid_co_var_of_co co cv) -almost_devoid_co_var_of_co (FunCo _ co1 co2) cv - = almost_devoid_co_var_of_co co1 cv +almost_devoid_co_var_of_co (FunCo _ w co1 co2) cv + = almost_devoid_co_var_of_co w cv + && almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv @@ -723,8 +724,9 @@ almost_devoid_co_var_of_type (LitTy {}) _ = True almost_devoid_co_var_of_type (AppTy fun arg) cv = almost_devoid_co_var_of_type fun cv && almost_devoid_co_var_of_type arg cv -almost_devoid_co_var_of_type (FunTy _ arg res) cv - = almost_devoid_co_var_of_type arg cv +almost_devoid_co_var_of_type (FunTy _ w arg res) cv + = almost_devoid_co_var_of_type w cv + && almost_devoid_co_var_of_type arg cv && almost_devoid_co_var_of_type res cv almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv = almost_devoid_co_var_of_type (varType v) cv @@ -779,12 +781,12 @@ injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? -> Type -> FV injectiveVarsOfType look_under_tfs = go where - go ty | Just ty' <- coreView ty - = go ty' - go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) - go (AppTy f a) = go f `unionFV` go a - go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 - go (TyConApp tc tys) = + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = case tyConInjectivityInfo tc of Injective inj | look_under_tfs || not (isTypeFamilyTyCon tc) @@ -837,7 +839,7 @@ invisibleVarsOfType = go = go ty' go (TyVarTy v) = go (tyVarKind v) go (AppTy f a) = go f `unionFV` go a - go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` invisibleVarsOfTypes visibles where (invisibles, visibles) = partitionInvisibleTypes tc tys diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index 40f901dc53..c6bf57e6d2 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -34,6 +34,7 @@ import {-# SOURCE #-} GHC.CoreToIface import {-# SOURCE #-} GHC.Core.DataCon ( dataConFullSig , dataConUserTyVarBinders , DataCon ) +import GHC.Core.Multiplicity import {-# SOURCE #-} GHC.Core.Type ( isLiftedTypeKind ) @@ -213,13 +214,18 @@ debug_ppr_ty _ (LitTy l) debug_ppr_ty _ (TyVarTy tv) = ppr tv -- With -dppr-debug we get (tv :: kind) -debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) +debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) = maybeParen prec funPrec $ - sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] + sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res] where - arrow = case af of - VisArg -> text "->" - InvisArg -> text "=>" + arr = case af of + VisArg -> case mult of + One -> lollipop + Many -> arrow + w -> mulArrow (ppr w) + InvisArg -> case mult of + Many -> darrow + _ -> pprPanic "unexpected multiplicity" (ppr ty) debug_ppr_ty prec (TyConApp tc tys) | null tys = ppr tc @@ -286,7 +292,7 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc forAllDoc = pprUserForAll user_bndrs thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) + argsDoc = hsep (fmap pprParendType (map scaledThing arg_tys)) pprTypeApp :: TyCon -> [Type] -> SDoc diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 684854045e..e201dcfea3 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -27,7 +27,7 @@ module GHC.Core.TyCo.Rep ( -- * Types Type( TyVarTy, AppTy, TyConApp, ForAllTy , LitTy, CastTy, CoercionTy - , FunTy, ft_arg, ft_res, ft_af + , FunTy, ft_mult, ft_arg, ft_res, ft_af ), -- Export the type synonym FunTy too TyLit(..), @@ -46,9 +46,13 @@ module GHC.Core.TyCo.Rep ( -- * Functions over types mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkPiTy, mkPiTys, + mkFunTyMany, + mkScaledFunTy, + mkVisFunTyMany, mkVisFunTysMany, + mkInvisFunTyMany, mkInvisFunTysMany, -- * Functions over binders TyCoBinder(..), TyCoVarBinder, TyBinder, @@ -83,6 +87,7 @@ import GHC.Iface.Type import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName ) +import GHC.Core.Multiplicity import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -210,9 +215,10 @@ data Type -- be mentioned in the Type. See -- Note [Unused coercion variable in ForAllTy] - | FunTy -- ^ t1 -> t2 Very common, so an important special case + | FunTy -- ^ FUN m t1 t2 Very common, so an important special case -- See Note [Function types] - { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + , ft_mult :: Mult -- Multiplicity , ft_arg :: Type -- Argument type , ft_res :: Type } -- Result type @@ -680,8 +686,8 @@ type KnotTied ty = ty -- not. See Note [TyCoBinders] data TyCoBinder = Named TyCoVarBinder -- A type-lambda binder - | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. - -- Visibility is determined by the AnonArgFlag + | Anon AnonArgFlag (Scaled Type) -- A term-lambda binder. Type here can be CoercionTy. + -- Visibility is determined by the AnonArgFlag deriving Data.Data instance Outputable TyCoBinder where @@ -980,19 +986,41 @@ mkTyCoVarTy v mkTyCoVarTys :: [TyCoVar] -> [Type] mkTyCoVarTys = map mkTyCoVarTy -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right +infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`, + `mkInvisFunTyMany` -- Associates to the right -mkFunTy :: AnonArgFlag -> Type -> Type -> Type -mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } +mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type +mkFunTy af mult arg res = FunTy { ft_af = af + , ft_mult = mult + , ft_arg = arg + , ft_res = res } -mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type +mkScaledFunTy :: AnonArgFlag -> Scaled Type -> Type -> Type +mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res + +mkVisFunTy, mkInvisFunTy :: Mult -> Type -> Type -> Type mkVisFunTy = mkFunTy VisArg mkInvisFunTy = mkFunTy InvisArg +mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type +mkFunTyMany af = mkFunTy af Many + +-- | Special, common, case: Arrow type with mult Many +mkVisFunTyMany :: Type -> Type -> Type +mkVisFunTyMany = mkVisFunTy Many + +mkInvisFunTyMany :: Type -> Type -> Type +mkInvisFunTyMany = mkInvisFunTy Many + -- | Make nested arrow types -mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type -mkVisFunTys tys ty = foldr mkVisFunTy ty tys -mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys +mkVisFunTys :: [Scaled Type] -> Type -> Type +mkVisFunTys tys ty = foldr (mkScaledFunTy VisArg) ty tys + +mkVisFunTysMany :: [Type] -> Type -> Type +mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys + +mkInvisFunTysMany :: [Type] -> Type -> Type +mkInvisFunTysMany tys ty = foldr mkInvisFunTyMany ty tys -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder -- See Note [Unused coercion variable in ForAllTy] @@ -1007,8 +1035,8 @@ mkForAllTys tyvars ty = foldr ForAllTy ty tyvars mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type mkInvisForAllTys tyvars ty = foldr ForAllTy ty $ tyVarSpecToBinders tyvars -mkPiTy:: TyCoBinder -> Type -> Type -mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } +mkPiTy :: TyCoBinder -> Type -> Type +mkPiTy (Anon af ty1) ty2 = mkScaledFunTy af ty1 ty2 mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty mkPiTys :: [TyCoBinder] -> Type -> Type @@ -1079,8 +1107,8 @@ data Coercion | ForAllCo TyCoVar KindCoercion Coercion -- ForAllCo :: _ -> N -> e -> e - | FunCo Role Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> e -> e -> e + | FunCo Role CoercionN Coercion Coercion -- lift FunTy + -- FunCo :: "e" -> N -> e -> e -> e -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? -- Because the AnonArgFlag has no impact on Core; it is only -- there to guide implicit instantiation of Haskell source @@ -1825,7 +1853,7 @@ foldTyCo (TyCoFolder { tcf_view = view go_ty _ (LitTy {}) = mempty go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co go_ty env (CoercionTy co) = go_co env co - go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res + go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res go_ty env (TyConApp _ tys) = go_tys env tys go_ty env (ForAllTy (Bndr tv vis) inner) = let !env' = tycobinder env tv vis -- Avoid building a thunk here @@ -1845,7 +1873,9 @@ foldTyCo (TyCoFolder { tcf_view = view go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co go_co env (TyConAppCo _ _ args) = go_cos env args go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (FunCo _ c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (FunCo _ cw c1 c2) = go_co env cw `mappend` + go_co env c1 `mappend` + go_co env c2 go_co env (CoVarCo cv) = covar env cv go_co env (AxiomInstCo _ _ args) = go_cos env args go_co env (HoleCo hole) = cohole env hole @@ -1892,7 +1922,7 @@ typeSize :: Type -> Int typeSize (LitTy {}) = 1 typeSize (TyVarTy {}) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy _ _ t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) typeSize (CastTy ty co) = typeSize ty + coercionSize co @@ -1905,7 +1935,8 @@ coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (AppCo co arg) = coercionSize co + coercionSize arg coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h -coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (FunCo _ w co1 co2) = 1 + coercionSize co1 + coercionSize co2 + + coercionSize w coercionSize (CoVarCo _) = 1 coercionSize (HoleCo _) = 1 coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index c7ce05f0a6..25a22435cf 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -1,5 +1,6 @@ module GHC.Core.TyCo.Rep where +import GHC.Utils.Outputable ( Outputable ) import Data.Data ( Data ) import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) @@ -17,7 +18,8 @@ type ThetaType = [PredType] type CoercionN = Coercion type MCoercionN = MCoercion -mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom +instance Outputable Type diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 0c8f77dfd8..88799c2414 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -33,12 +33,12 @@ module GHC.Core.TyCo.Subst substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, substCoWith, - substTy, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, + substTy, substTyAddInScope, substScaledTy, + substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, substScaledTyUnchecked, substCoUnchecked, substCoWithUnchecked, substTyWithInScope, - substTys, substTheta, + substTys, substScaledTys, substTheta, lookupTyVar, substCo, substCos, substCoVar, substCoVars, lookupCoVar, cloneTyVarBndr, cloneTyVarBndrs, @@ -69,6 +69,7 @@ import {-# SOURCE #-} GHC.Core.Coercion import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr +import GHC.Core.Multiplicity import GHC.Types.Var import GHC.Types.Var.Set @@ -673,6 +674,12 @@ substTyUnchecked subst ty | isEmptyTCvSubst subst = ty | otherwise = subst_ty subst ty +substScaledTy :: HasCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty + +substScaledTyUnchecked :: HasCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty + -- | Substitute within several 'Type's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. @@ -681,6 +688,12 @@ substTys subst tys | isEmptyTCvSubst subst = tys | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys +substScaledTys :: HasCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTys subst scaled_tys + | isEmptyTCvSubst subst = scaled_tys + | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $ + map (mapScaledType (subst_ty subst)) scaled_tys + -- | Substitute within several 'Type's disabling the sanity checks. -- The problems that the sanity checks in substTys catch are described in -- Note [The substitution invariant]. @@ -691,6 +704,11 @@ substTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (subst_ty subst) tys +substScaledTysUnchecked :: TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (mapScaledType (subst_ty subst)) tys + -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. @@ -721,10 +739,11 @@ subst_ty subst ty -- by [Int], represented with TyConApp go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args - go ty@(FunTy { ft_arg = arg, ft_res = res }) - = let !arg' = go arg + go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) + = let !mult' = go mult + !arg' = go arg !res' = go res - in ty { ft_arg = arg', ft_res = res' } + in ty { ft_mult = mult', ft_arg = arg', ft_res = res' } go (ForAllTy (Bndr tv vis) ty) = case substVarBndrUnchecked subst tv of (subst', tv') -> @@ -805,7 +824,7 @@ subst_co subst co = case substForAllCoBndrUnchecked subst tv kind_co of (subst', tv', kind_co') -> ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co - go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 + go (FunCo r w co1 co2) = ((mkFunCo r $! go w) $! go co1) $! go co2 go (CoVarCo cv) = substCoVar subst cv go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! @@ -827,7 +846,7 @@ subst_co subst co -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) - = h { ch_co_var = updateVarType go_ty cv } + = h { ch_co_var = updateVarTypeAndMult go_ty cv } substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion -> (TCvSubst, TyCoVar, Coercion) diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index 6cfce74790..bc586d77c8 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -52,8 +52,7 @@ tidyVarBndr tidy_env@(occ_env, subst) var (occ_env', occ') -> ((occ_env', subst'), var') where subst' = extendVarEnv subst var var' - var' = setVarType (setVarName var name') type' - type' = tidyType tidy_env (varType var) + var' = updateVarTypeAndMult (tidyType tidy_env) (setVarName var name') name' = tidyNameOcc name occ' name = varName var @@ -120,7 +119,7 @@ tidyOpenTyCoVar env@(_, subst) tyvar tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar tidyTyCoVarOcc env@(_, subst) tv = case lookupVarEnv subst tv of - Nothing -> updateVarType (tidyType env) tv + Nothing -> updateVarTypeAndMult (tidyType env) tv Just tv' -> tv' --------------- @@ -134,9 +133,10 @@ tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg - ; !res' = tidyType env res } - in ty { ft_arg = arg', ft_res = res' } +tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w + ; !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_mult = w', ft_arg = arg', ft_res = res' } tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty where (tvs, vis, body_ty) = splitForAllTys' ty @@ -208,7 +208,7 @@ tidyCo env@(_, subst) co where (envp, tvp) = tidyVarBndr env tv -- the case above duplicates a bit of work in tidying h and the kind -- of tv. But the alternative is to use coercionKind, which seems worse. - go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 + go (FunCo r w co1 co2) = ((FunCo r $! go w) $! go co1) $! go co2 go (CoVarCo cv) = case lookupVarEnv subst cv of Nothing -> CoVarCo cv Just cv' -> CoVarCo cv' diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 80b4500685..eac2d8b109 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -138,11 +138,12 @@ import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Core.TyCo.Rep - ( Kind, Type, PredType, mkForAllTy, mkFunTy ) + ( Kind, Type, PredType, mkForAllTy, mkFunTyMany ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types ( runtimeRepTyCon, constraintKind + , multiplicityTyCon , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} GHC.Core.DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels @@ -489,7 +490,7 @@ mkTyConKind :: [TyConBinder] -> Kind -> Kind mkTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: TyConBinder -> Kind -> Kind - mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k + mk (Bndr tv (AnonTCB af)) k = mkFunTyMany af (varType tv) k mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k tyConInvisTVBinders :: [TyConBinder] -- From the TyCon @@ -2213,6 +2214,7 @@ kindTyConKeys :: UniqSet Unique kindTyConKeys = unionManyUniqSets ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + , multiplicityTyCon , vecCountTyCon, vecElemTyCon ] ) where tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) @@ -2410,7 +2412,7 @@ tyConRoles :: TyCon -> [Role] -- See also Note [TyCon Role signatures] tyConRoles tc = case tc of - { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] + { FunTyCon {} -> [Nominal, Nominal, Nominal, Representational, Representational] ; AlgTyCon { tcRoles = roles } -> roles ; SynonymTyCon { tcRoles = roles } -> roles ; FamilyTyCon {} -> const_role Nominal diff --git a/compiler/GHC/Core/TyCon.hs-boot b/compiler/GHC/Core/TyCon.hs-boot index 1081249d19..c561da08f9 100644 --- a/compiler/GHC/Core/TyCon.hs-boot +++ b/compiler/GHC/Core/TyCon.hs-boot @@ -1,9 +1,12 @@ module GHC.Core.TyCon where import GHC.Prelude +import GHC.Types.Unique ( Uniquable ) data TyCon +instance Uniquable TyCon + isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool isFunTyCon :: TyCon -> Bool diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index a183308526..bdf9ba21da 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -19,6 +19,7 @@ module GHC.Core.Type ( Specificity(..), KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, + Mult, Scaled, KnotTied, -- ** Constructing and deconstructing types @@ -28,7 +29,10 @@ module GHC.Core.Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, - mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + mkVisFunTy, mkInvisFunTy, + mkVisFunTys, + mkVisFunTyMany, mkInvisFunTyMany, + mkVisFunTysMany, mkInvisFunTysMany, splitFunTy, splitFunTy_maybe, splitFunTys, funResultTy, funArgTy, @@ -93,7 +97,7 @@ module GHC.Core.Type ( -- ** Binders sameVis, mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinders, + mkTyVarBinder, mkTyVarBinders, tyVarSpecToBinders, mkAnonBinder, isAnonTyCoBinder, @@ -106,7 +110,7 @@ module GHC.Core.Type ( tyConBindersTyCoBinders, -- ** Common type constructors - funTyCon, + funTyCon, unrestrictedFunTyCon, -- ** Predicates on types isTyVarTy, isFunTy, isCoercionTy, @@ -129,6 +133,11 @@ module GHC.Core.Type ( dropRuntimeRepArgs, getRuntimeRep, + -- Multiplicity + + isMultiplicityTy, isMultiplicityVar, + isLinearType, + -- * Main data types representing Kinds Kind, @@ -196,10 +205,10 @@ module GHC.Core.Type ( isEmptyTCvSubst, unionTCvSubst, -- ** Performing substitution on types and kinds - substTy, substTys, substTyWith, substTysWith, substTheta, + substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, + substThetaUnchecked, substTyWithUnchecked, substCoUnchecked, substCoWithUnchecked, substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, substVarBndr, substVarBndrs, @@ -235,6 +244,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs +import GHC.Core.Multiplicity -- friends: import GHC.Types.Var @@ -248,7 +258,8 @@ import {-# SOURCE #-} GHC.Builtin.Types ( listTyCon, typeNatKind , typeSymbolKind, liftedTypeKind , liftedTypeKindTyCon - , constraintKind ) + , constraintKind + , unrestrictedFunTyCon ) import GHC.Types.Name( Name ) import GHC.Builtin.Names import GHC.Core.Coercion.Axiom @@ -425,8 +436,8 @@ expandTypeSynonyms ty go _ (LitTy l) = LitTy l go subst (TyVarTy tv) = substTyVar subst tv go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst ty@(FunTy _ arg res) - = ty { ft_arg = go subst arg, ft_res = go subst res } + go subst ty@(FunTy _ mult arg res) + = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } go subst (ForAllTy (Bndr tv vis) t) = let (subst', tv') = substVarBndrUsing go subst tv in ForAllTy (Bndr tv' vis) (go subst' t) @@ -448,8 +459,8 @@ expandTypeSynonyms ty go_co subst (ForAllCo tv kind_co co) = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in mkForAllCo tv' kind_co' (go_co subst' co) - go_co subst (FunCo r co1 co2) - = mkFunCo r (go_co subst co1) (go_co subst co2) + go_co subst (FunCo r w co1 co2) + = mkFunCo r (go_co subst w) (go_co subst co1) (go_co subst co2) go_co subst (CoVarCo cv) = substCoVar subst cv go_co subst (AxiomInstCo ax ind args) @@ -559,6 +570,28 @@ isRuntimeRepTy _ = False isRuntimeRepVar :: TyVar -> Bool isRuntimeRepVar = isRuntimeRepTy . tyVarKind +-- | Is this the type 'Multiplicity'? +isMultiplicityTy :: Type -> Bool +isMultiplicityTy ty | Just ty' <- coreView ty = isMultiplicityTy ty' +isMultiplicityTy (TyConApp tc []) = tc `hasKey` multiplicityTyConKey +isMultiplicityTy _ = False + +-- | Is a tyvar of type 'Multiplicity'? +isMultiplicityVar :: TyVar -> Bool +isMultiplicityVar = isMultiplicityTy . tyVarKind + +isLinearType :: Type -> Bool +-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function +-- where at least one argument is linear (or otherwise non-unrestricted). We use +-- this function to check whether it is safe to eta reduce an Id in CorePrep. It +-- is always safe to return 'True', because 'True' deactivates the optimisation. +isLinearType ty = case ty of + FunTy _ Many _ res -> isLinearType res + FunTy _ _ _ _ -> True + ForAllTy _ res -> isLinearType res + _ + | Just ty' <- coreView ty -> isLinearType ty' + | otherwise -> False {- ********************************************************************* * * @@ -655,9 +688,9 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co go_ty env (CoercionTy co) = CoercionTy <$> go_co env co - go_ty env ty@(FunTy _ arg res) - = do { arg' <- go_ty env arg; res' <- go_ty env res - ; return (ty { ft_arg = arg', ft_res = res' }) } + go_ty env ty@(FunTy _ w arg res) + = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res + ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } go_ty env ty@(TyConApp tc tys) | isTcTyCon tc @@ -685,7 +718,7 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar go_co env (Refl ty) = Refl <$> go_ty env ty go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 - go_co env (FunCo r c1 c2) = mkFunCo r <$> go_co env c1 <*> go_co env c2 + go_co env (FunCo r cw c1 c2) = mkFunCo r <$> go_co env cw <*> go_co env c1 <*> go_co env c2 go_co env (CoVarCo cv) = covar env cv go_co env (HoleCo hole) = cohole env hole go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r @@ -844,8 +877,8 @@ splitAppTy_maybe ty = repSplitAppTy_maybe ty repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that -- any Core view stuff is already done -repSplitAppTy_maybe (FunTy _ ty1 ty2) - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) +repSplitAppTy_maybe (FunTy _ w ty1 ty2) + = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 @@ -866,12 +899,11 @@ repSplitAppTy_maybe _other = Nothing tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that -- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) +tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) | InvisArg <- af = Nothing -- See Note [Decomposing fat arrow c=>t] - | otherwise - = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 @@ -907,9 +939,9 @@ splitAppTys ty = split ty ty [] (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy _ ty1 ty2) args + split _ (FunTy _ w ty1 ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 @@ -927,9 +959,9 @@ repSplitAppTys ty = split ty [] (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split (FunTy _ ty1 ty2) args + split (FunTy _ w ty1 ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 @@ -1041,25 +1073,25 @@ In the compiler we maintain the invariant that all saturated applications of See #11714. -} -splitFunTy :: Type -> (Type, Type) +splitFunTy :: Type -> (Scaled Type, Type) -- ^ Attempts to extract the argument and result types from a type, and -- panics if that is not possible. See also 'splitFunTy_maybe' splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (FunTy _ arg res) = (arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) +splitFunTy (FunTy _ w arg res) = (Scaled w arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) -splitFunTy_maybe :: Type -> Maybe (Type, Type) +splitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) -- ^ Attempts to extract the argument and result types from a type splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) -splitFunTy_maybe _ = Nothing +splitFunTy_maybe (FunTy _ w arg res) = Just (Scaled w arg, res) +splitFunTy_maybe _ = Nothing -splitFunTys :: Type -> ([Type], Type) +splitFunTys :: Type -> ([Scaled Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (FunTy _ arg res) = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) + split args _ (FunTy _ w arg res) = split ((Scaled w arg):args) res res + split args orig_ty _ = (reverse args, orig_ty) funResultTy :: Type -> Type -- ^ Extract the function result type and panic if that is not possible @@ -1237,9 +1269,10 @@ compilation. In order to avoid a potentially expensive series of checks in mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon - , [_rep1,_rep2,ty1,ty2] <- tys + , [w, _rep1,_rep2,ty1,ty2] <- tys -- The FunTyCon (->) is always a visible one - = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } + = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } + -- Note [mkTyConApp and Type] | tycon == liftedTypeKindTyCon = ASSERT2( null tys, ppr tycon $$ ppr tys ) @@ -1279,10 +1312,10 @@ tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr tyConAppArgs_maybe :: Type -> Maybe [Type] tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (FunTy _ arg res) +tyConAppArgs_maybe (FunTy _ w arg res) | Just rep1 <- getRuntimeRep_maybe arg , Just rep2 <- getRuntimeRep_maybe res - = Just [rep1, rep2, arg, res] + = Just [w, rep1, rep2, arg, res] tyConAppArgs_maybe _ = Nothing tyConAppArgs :: Type -> [Type] @@ -1333,10 +1366,10 @@ repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- see Note [FunTy and decomposing tycon applications] in GHC.Tc.Solver.Canonical -- repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy _ arg res) +repSplitTyConApp_maybe (FunTy _ w arg res) | Just arg_rep <- getRuntimeRep_maybe arg , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [arg_rep, res_rep, arg, res]) + = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) repSplitTyConApp_maybe _ = Nothing ------------------- @@ -1404,7 +1437,7 @@ tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] tyConBindersTyCoBinders = map to_tyb where to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) - to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) + to_tyb (Bndr tv (AnonTCB af)) = Anon af (tymult (varType tv)) -- | Drop the cast on a type, if any. If there is no -- cast, just return the original type. This is rarely what @@ -1474,7 +1507,7 @@ mkTyCoInvForAllTy :: TyCoVar -> Type -> Type mkTyCoInvForAllTy tv ty | isCoVar tv , not (tv `elemVarSet` tyCoVarsOfType ty) - = mkVisFunTy (varType tv) ty + = mkVisFunTyMany (varType tv) ty | otherwise = ForAllTy (Bndr tv Inferred) ty @@ -1529,18 +1562,21 @@ mkLamType v body_ty = ForAllTy (Bndr v Required) body_ty | otherwise - = mkFunctionType (varType v) body_ty + = mkFunctionType arg_mult arg_ty body_ty + where + Scaled arg_mult arg_ty = varScaledType v -mkFunctionType :: Type -> Type -> Type +mkFunctionType :: Mult -> Type -> Type -> Type -- This one works out the AnonArgFlag from the argument type -- See GHC.Types.Var Note [AnonArgFlag] -mkFunctionType arg_ty res_ty +mkFunctionType mult arg_ty res_ty | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] - = mkInvisFunTy arg_ty res_ty + = ASSERT(eqType mult Many) + mkInvisFunTy mult arg_ty res_ty | otherwise - = mkVisFunTy arg_ty res_ty + = mkVisFunTy mult arg_ty res_ty -- | Given a list of type-level vars and the free vars of a result kind, -- makes TyCoBinders, preferring anonymous binders @@ -1705,8 +1741,8 @@ splitPiTy_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' go (ForAllTy bndr ty) = Just (Named bndr, ty) - go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) - = Just (Anon af arg, res) + go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}) + = Just (Anon af (mkScaled w arg), res) go _ = Nothing -- | Takes a forall type apart, or panics @@ -1722,8 +1758,8 @@ splitPiTys ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs = split res res (Named b : bs) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs - = split res res (Anon af arg : bs) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs + = split res res (Anon af (Scaled w arg) : bs) split orig_ty _ bs = (reverse bs, orig_ty) -- | Like 'splitPiTys' but split off only /named/ binders @@ -1753,8 +1789,8 @@ splitPiTysInvisible ty = split ty ty [] split _ (ForAllTy b res) bs | Bndr _ vis <- b , isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs - = split res res (Anon InvisArg arg : bs) + split _ (FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res }) bs + = split res res (Anon InvisArg (mkScaled mult arg) : bs) split orig_ty _ bs = (reverse bs, orig_ty) splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) @@ -1769,8 +1805,8 @@ splitPiTysInvisibleN n ty = split n ty ty [] | ForAllTy b res <- ty , Bndr _ vis <- b , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) - | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty - = split (n-1) res res (Anon InvisArg arg : bs) + | FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty + = split (n-1) res res (Anon InvisArg (Scaled mult arg) : bs) | otherwise = (reverse bs, orig_ty) -- | Given a 'TyCon' and a list of argument types, filter out any invisible @@ -1875,9 +1911,9 @@ isTauTy (TyVarTy _) = True isTauTy (LitTy {}) = True isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy af a b) = case af of - InvisArg -> False -- e.g., Eq a => b - VisArg -> isTauTy a && isTauTy b -- e.g., a -> b +isTauTy (FunTy af w a b) = case af of + InvisArg -> False -- e.g., Eq a => b + VisArg -> isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b isTauTy (ForAllTy {}) = False isTauTy (CastTy ty _) = isTauTy ty isTauTy (CoercionTy _) = False -- Not sure about this @@ -1905,7 +1941,7 @@ isAtomicTy _ = False -} -- | Make an anonymous binder -mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder +mkAnonBinder :: AnonArgFlag -> Scaled Type -> TyCoBinder mkAnonBinder = Anon -- | Does this binder bind a variable that is /not/ erased? Returns @@ -1920,18 +1956,18 @@ tyCoBinderVar_maybe _ = Nothing tyCoBinderType :: TyCoBinder -> Type tyCoBinderType (Named tvb) = binderType tvb -tyCoBinderType (Anon _ ty) = ty +tyCoBinderType (Anon _ ty) = scaledThing ty tyBinderType :: TyBinder -> Type tyBinderType (Named (Bndr tv _)) = ASSERT( isTyVar tv ) tyVarKind tv -tyBinderType (Anon _ ty) = ty +tyBinderType (Anon _ ty) = scaledThing ty -- | Extract a relevant type, if there is one. binderRelevantType_maybe :: TyCoBinder -> Maybe Type -binderRelevantType_maybe (Named {}) = Nothing -binderRelevantType_maybe (Anon _ ty) = Just ty +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon _ ty) = Just (scaledThing ty) {- ************************************************************************ @@ -1972,7 +2008,7 @@ isFamFreeTy (TyVarTy _) = True isFamFreeTy (LitTy {}) = True isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty isFamFreeTy (CastTy ty _) = isFamFreeTy ty isFamFreeTy (CoercionTy _) = False -- Not sure about this @@ -2192,7 +2228,7 @@ seqType :: Type -> () seqType (LitTy n) = n `seq` () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty seqType (CastTy ty co) = seqType ty `seq` seqCo co @@ -2345,8 +2381,9 @@ nonDetCmpTypeX env orig_t1 orig_t2 = go env ty1 (AppTy s2 t2) | Just (s1, t1) <- repSplitAppTy_maybe ty1 = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (FunTy _ s1 t1) (FunTy _ s2 t2) - = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + = go env w1 w2 `thenCmpTy` + go env s1 s2 `thenCmpTy` go env t1 t2 go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) @@ -2707,10 +2744,11 @@ occCheckExpand vs_to_avoid ty go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 ; return (mkAppTy ty1' ty2') } - go cxt ty@(FunTy _ ty1 ty2) - = do { ty1' <- go cxt ty1 + go cxt ty@(FunTy _ w ty1 ty2) + = do { w' <- go cxt w + ; ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 - ; return (ty { ft_arg = ty1', ft_res = ty2' }) } + ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) = do { ki' <- go cxt (varType tv) ; let tv' = setVarType tv ki' @@ -2737,8 +2775,7 @@ occCheckExpand vs_to_avoid ty ; return (mkCoercionTy co') } ------------------ - go_var cxt v = do { k' <- go cxt (varType v) - ; return (setVarType v k') } + go_var cxt v = updateVarTypeAndMultM (go cxt) v -- Works for TyVar and CoVar -- See Note [Occurrence checking: look inside kinds] @@ -2766,9 +2803,10 @@ occCheckExpand vs_to_avoid ty as' = as `delVarSet` tv ; body' <- go_co (as', env') body_co ; return (ForAllCo tv' kind_co' body') } - go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 + go_co cxt (FunCo r w co1 co2) = do { co1' <- go_co cxt co1 ; co2' <- go_co cxt co2 - ; return (mkFunCo r co1' co2') } + ; w' <- go_co cxt w + ; return (mkFunCo r w' co1' co2') } go_co cxt@(as,env) (CoVarCo c) | c `elemVarSet` as = Nothing | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') @@ -2828,7 +2866,8 @@ tyConsOfType ty go (LitTy {}) = emptyUniqSet go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys go (AppTy a b) = go a `unionUniqSets` go b - go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon + go (FunTy _ w a b) = go w `unionUniqSets` + go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) go (CastTy ty co) = go ty `unionUniqSets` go_co co go (CoercionTy co) = go_co co @@ -2838,7 +2877,7 @@ tyConsOfType ty go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co - go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (FunCo _ co_mult co1 co2) = go_co co_mult `unionUniqSets` go_co co1 `unionUniqSets` go_co co2 go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 go_co (CoVarCo {}) = emptyUniqSet @@ -2886,7 +2925,7 @@ splitVisVarsOfType orig_ty = Pair invis_vars vis_vars go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) go (AppTy t1 t2) = go t1 `mappend` go t2 go (TyConApp tc tys) = go_tc tc tys - go (FunTy _ t1 t2) = go t1 `mappend` go t2 + go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 go (ForAllTy (Bndr tv _) ty) = ((`delVarSet` tv) <$> go ty) `mappend` (invisible (tyCoVarsOfType $ varType tv)) @@ -2971,7 +3010,7 @@ isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) go AppTy{} = True -- it can't be a TyConApp go (TyConApp tc tys) = isFamilyTyCon tc || any go tys go ForAllTy{} = True - go (FunTy _ t1 t2) = go t1 || go t2 + go (FunTy _ w t1 t2) = go w || go t1 || go t2 go LitTy{} = False go CastTy{} = True go CoercionTy{} = True diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index 08efbf608d..1faf4304ab 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -3,7 +3,7 @@ module GHC.Core.Type where import GHC.Prelude -import GHC.Core.TyCon +import {-# SOURCE #-} GHC.Core.TyCon import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) import GHC.Utils.Misc @@ -19,8 +19,11 @@ eqType :: Type -> Type -> Bool coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool +isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +mkTyConApp :: TyCon -> [Type] -> Type + partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 8eac3fbf63..84aa76d573 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -1041,7 +1041,9 @@ unify_ty env (CoercionTy co1) (CoercionTy co2) kco , not (cv `elemVarEnv` c_subst) , BindMe <- tvBindFlag env cv -> do { checkRnEnv env (tyCoVarsOfCo co2) - ; let (co_l, co_r) = decomposeFunCo Nominal kco + ; let (_, co_l, co_r) = decomposeFunCo Nominal kco + -- Because the coercion is nominal, it should be safe to + -- ignore the multiplicity coercion. -- cv :: t1 ~ t2 -- co2 :: s1 ~ s2 -- co_l :: t1 ~ s1 @@ -1463,15 +1465,15 @@ ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco = ty_co_match_tc menv subst tc1 tys tc2 cos -ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco - -- Despite the fact that (->) is polymorphic in four type variables (two - -- runtime rep and two types), we shouldn't need to explicitly unify the - -- runtime reps here; unifying the types themselves should be sufficient. - -- See Note [Representation of function types]. - | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co +ty_co_match menv subst (FunTy _ w ty1 ty2) co _lkco _rkco + -- Despite the fact that (->) is polymorphic in five type variables (two + -- runtime rep, a multiplicity and two types), we shouldn't need to + -- explicitly unify the runtime reps here; unifying the types themselves + -- should be sufficient. See Note [Representation of function types]. + | Just (tc, [co_mult, _,_,co1,co2]) <- splitTyConAppCo_maybe co , tc == funTyCon - = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] - in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos + = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co_mult,co1,co2] + in ty_co_match_args menv subst [w, ty1, ty2] [co_mult, co1, co2] lkcos rkcos ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) (ForAllCo tv2 kind_co2 co2) @@ -1575,10 +1577,10 @@ pushRefl co = case (isReflCo_maybe co) of Just (AppTy ty1 ty2, Nominal) -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) - Just (FunTy _ ty1 ty2, r) + Just (FunTy _ w ty1 ty2, r) | Just rep1 <- getRuntimeRep_maybe ty1 , Just rep2 <- getRuntimeRep_maybe ty2 - -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 + -> Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2 , mkReflCo r ty1, mkReflCo r ty2 ]) Just (TyConApp tc tys, r) -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) diff --git a/compiler/GHC/Core/UsageEnv.hs b/compiler/GHC/Core/UsageEnv.hs new file mode 100644 index 0000000000..a03343ee9f --- /dev/null +++ b/compiler/GHC/Core/UsageEnv.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ViewPatterns #-} +module GHC.Core.UsageEnv (UsageEnv, addUsage, scaleUsage, zeroUE, + lookupUE, scaleUE, deleteUE, addUE, Usage(..), unitUE, + supUE, supUEs) where + +import Data.Foldable +import GHC.Prelude +import GHC.Core.Multiplicity +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable + +-- +-- * Usage environments +-- + +-- The typechecker and the linter output usage environments. See Note [Usages] +-- in Multiplicity. Every absent name being considered to map to 'Zero' of +-- 'Bottom' depending on a flag. See Note [Zero as a usage] in Multiplicity, see +-- Note [Bottom as a usage] in Multiplicity. + +data Usage = Zero | Bottom | MUsage Mult + +instance Outputable Usage where + ppr Zero = text "0" + ppr Bottom = text "Bottom" + ppr (MUsage x) = ppr x + +addUsage :: Usage -> Usage -> Usage +addUsage Zero x = x +addUsage x Zero = x +addUsage Bottom x = x +addUsage x Bottom = x +addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y + +scaleUsage :: Mult -> Usage -> Usage +scaleUsage One Bottom = Bottom +scaleUsage _ Zero = Zero +scaleUsage x Bottom = MUsage x +scaleUsage x (MUsage y) = MUsage $ mkMultMul x y + +-- For now, we use extra multiplicity Bottom for empty case. +data UsageEnv = UsageEnv (NameEnv Mult) Bool + +unitUE :: NamedThing n => n -> Mult -> UsageEnv +unitUE x w = UsageEnv (unitNameEnv (getName x) w) False + +zeroUE, bottomUE :: UsageEnv +zeroUE = UsageEnv emptyNameEnv False + +bottomUE = UsageEnv emptyNameEnv True + +addUE :: UsageEnv -> UsageEnv -> UsageEnv +addUE (UsageEnv e1 b1) (UsageEnv e2 b2) = + UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2) + +scaleUE :: Mult -> UsageEnv -> UsageEnv +scaleUE One ue = ue +scaleUE w (UsageEnv e _) = + UsageEnv (mapNameEnv (mkMultMul w) e) False + +supUE :: UsageEnv -> UsageEnv -> UsageEnv +supUE (UsageEnv e1 False) (UsageEnv e2 False) = + UsageEnv (plusNameEnv_CD mkMultSup e1 Many e2 Many) False +supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage e1 e2) (b1 && b2) + where combineUsage (Just x) (Just y) = mkMultSup x y + combineUsage Nothing (Just x) | b1 = x + | otherwise = Many + combineUsage (Just x) Nothing | b2 = x + | otherwise = Many + combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2) +-- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. + +supUEs :: [UsageEnv] -> UsageEnv +supUEs = foldr supUE bottomUE + + +deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv +deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b + +-- | |lookupUE x env| returns the multiplicity assigned to |x| in |env|, if |x| is not +-- bound in |env|, then returns |Zero| or |Bottom|. +lookupUE :: NamedThing n => UsageEnv -> n -> Usage +lookupUE (UsageEnv e has_bottom) x = + case lookupNameEnv e (getName x) of + Just w -> MUsage w + Nothing -> if has_bottom then Bottom else Zero + +instance Outputable UsageEnv where + ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 700ab14b1e..9748dd2753 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -20,6 +20,7 @@ module GHC.Core.Utils ( findDefault, addDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, filterAlts, combineIdenticalAlts, refineDefaultAlt, + scaleAltsBy, -- * Properties of expressions exprType, coreAltType, coreAltsType, isExprLevPoly, @@ -88,6 +89,7 @@ import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) import GHC.Core.Coercion import GHC.Core.TyCon +import GHC.Core.Multiplicity import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Builtin.Types.Prim @@ -237,7 +239,7 @@ applyTypeToArgs e op_ty args go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty = go res_ty args - go _ _ = pprPanic "applyTypeToArgs" panic_msg + go _ args = pprPanic "applyTypeToArgs" (panic_msg args) -- go_ty_args: accumulate type arguments so we can -- instantiate all at once with piResultTys @@ -248,9 +250,10 @@ applyTypeToArgs e op_ty args go_ty_args op_ty rev_tys args = go (piResultTys op_ty (reverse rev_tys)) args - panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e + panic_msg as = vcat [ text "Expression:" <+> pprCoreExpr e , text "Type:" <+> ppr op_ty - , text "Args:" <+> ppr args ] + , text "Args:" <+> ppr args + , text "Args':" <+> ppr as ] {- @@ -295,7 +298,8 @@ mkCast expr co WARN( not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" - $$ ppr co $$ ppr (coercionType co) ) + $$ ppr co $$ ppr (coercionType co) + $$ callStackDoc ) (Cast expr co) -- | Wraps the given expression in the source annotation, dropping the @@ -701,12 +705,13 @@ filterAlts _tycon inst_tys imposs_cons alts -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. -- See Note [Refine DEFAULT case alternatives] refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders + -> Mult -- ^ Multiplicity annotation of the case expression -> TyCon -- ^ Type constructor of scrutinee's type -> [Type] -- ^ Type arguments of scrutinee's type -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) -> [CoreAlt] -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' -refineDefaultAlt us tycon tys imposs_deflt_cons all_alts +refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts | (DEFAULT,_,rhs) : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: @@ -727,7 +732,7 @@ refineDefaultAlt us tycon tys imposs_deflt_cons all_alts [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) -- We need the mergeAlts to keep the alternatives in the right order where - (ex_tvs, arg_ids) = dataConRepInstPat us con tys + (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys -- It matches more than one, so do nothing _ -> (False, all_alts) @@ -930,6 +935,18 @@ combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) combineIdenticalAlts imposs_cons alts = (False, imposs_cons, alts) +-- Scales the multiplicity of the binders of a list of case alternatives. That +-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled. +scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] +scaleAltsBy w alts = map scaleAlt alts + where + scaleAlt :: CoreAlt -> CoreAlt + scaleAlt (con, bndrs, rhs) = (con, map scaleBndr bndrs, rhs) + + scaleBndr :: CoreBndr -> CoreBndr + scaleBndr = scaleVarBy w + + {- ********************************************************************* * * exprIsTrivial @@ -1608,7 +1625,7 @@ app_ok primop_ok fun args primop_arg_ok :: TyBinder -> CoreExpr -> Bool primop_arg_ok (Named _) _ = True -- A type argument primop_arg_ok (Anon _ ty) arg -- A term argument - | isUnliftedType ty = expr_ok primop_ok arg + | isUnliftedType (scaledThing ty) = expr_ok primop_ok arg | otherwise = True -- See Note [Primops with lifted arguments] ----------------------------- @@ -1941,18 +1958,19 @@ exprIsTickedString_maybe _ = Nothing These InstPat functions go here to avoid circularity between DataCon and Id -} -dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) dataConRepFSInstPat = dataConInstPat dataConInstPat :: [FastString] -- A long enough list of FSs to use for names -> [Unique] -- An equally long list of uniques, at least one for each binder + -> Mult -- The multiplicity annotation of the case expression: scales the multiplicity of variables -> DataCon -> [Type] -- Types to instantiate the universally quantified tyvars -> ([TyCoVar], [Id]) -- Return instantiated variables --- dataConInstPat arg_fun fss us con inst_tys returns a tuple +-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple -- (ex_tvs, arg_ids), -- -- ex_tvs are intended to be used as binders for existential type args @@ -1979,7 +1997,7 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys +dataConInstPat fss uniqs mult con inst_tys = ASSERT( univ_tvs `equalLength` inst_tys ) (ex_bndrs, arg_ids) where @@ -2013,9 +2031,9 @@ dataConInstPat fss uniqs con inst_tys -- Make value vars, instantiating types arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs - mk_id_var uniq fs ty str + mk_id_var uniq fs (Scaled m ty) str = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] - mkLocalIdOrCoVar name (Type.substTy full_subst ty) + mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty) where name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan @@ -2299,6 +2317,14 @@ There are some particularly delicate points here: So it's important to do the right thing. +* With linear types, eta-reduction can break type-checking: + f :: A ⊸ B + g :: A -> B + g = \x. f x + + The above is correct, but eta-reducing g would yield g=f, the linter will + complain that g and f don't have the same type. + * Note [Arity care]: we need to be careful if we just look at f's arity. Currently (Dec07), f's arity is visible in its own RHS (see Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the @@ -2382,7 +2408,7 @@ tryEtaReduce bndrs body -- Float app ticks: \x -> Tick t (e x) ==> Tick t e go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co + | Just (co', ticks) <- ok_arg b arg co (exprType fun) = fmap (flip (foldr mkTick) ticks) $ go bs fun co' -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e @@ -2417,27 +2443,34 @@ tryEtaReduce bndrs body ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t -> Coercion -- Of kind (t1~t2) + -> Type -- Type of the function to which the argument is applied -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [Tickish Var]) -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co + ok_arg bndr (Type ty) co _ | Just tv <- getTyVar_maybe ty , bndr == tv = Just (mkHomoForAllCos [tv] co, []) - ok_arg bndr (Var v) co - | bndr == v = let reflCo = mkRepReflCo (idType bndr) - in Just (mkFunCo Representational reflCo co, []) - ok_arg bndr (Cast e co_arg) co + ok_arg bndr (Var v) co fun_ty + | bndr == v + , let mult = idMult bndr + , Just (Scaled fun_mult _, _) <- splitFunTy_maybe fun_ty + , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort + = let reflCo = mkRepReflCo (idType bndr) + in Just (mkFunCo Representational (multToCo mult) reflCo co, []) + ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e + , Just (Scaled fun_mult _, _) <- splitFunTy_maybe fun_ty , bndr == v - = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) + , fun_mult `eqType` idMult bndr + = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty = Just (co', t:ticks) - ok_arg _ _ _ = Nothing + ok_arg _ _ _ _ = Nothing {- Note [Eta reduction of an eval'd function] diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 96f1f96e63..5c6b034360 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- @@ -28,7 +29,7 @@ import GHC.Platform import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id -import GHC.Types.Var ( updateVarType ) +import GHC.Types.Var ( updateVarTypeButNotMult ) import GHC.Types.ForeignCall import GHC.Driver.Types import GHC.Core.Utils @@ -37,6 +38,7 @@ import GHC.Core.Ppr import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Core.FVs +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon @@ -625,7 +627,7 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) -- Here (k n) :: a :: Type r, so we don't know if it's lifted -- or not; but that should be fine provided we add that void arg. - id <- newId (mkVisFunTy realWorldStatePrimTy ty) + id <- newId (mkVisFunTyMany realWorldStatePrimTy ty) st <- newId realWorldStatePrimTy let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id) @@ -708,7 +710,7 @@ protectNNLJoinPointBind x rhs@(fvs, _) protectNNLJoinPointId :: Id -> Id protectNNLJoinPointId x = ASSERT( isNNLJoinPoint x ) - updateVarType (voidPrimTy `mkVisFunTy`) x + updateVarTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x {- Ticked Expressions @@ -2060,7 +2062,7 @@ getTopStrings = BcM $ \st -> return (st, topStrings st) newId :: Type -> BcM Id newId ty = do uniq <- newUnique - return $ mkSysLocal tickFS uniq ty + return $ mkSysLocal tickFS uniq Many ty tickFS :: FastString tickFS = fsLit "ticked" diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 1c6b09e669..2992fa5c0f 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -63,6 +63,7 @@ import GHC.Builtin.Names import GHC.Types.Name import GHC.Types.Basic import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.PatSyn import GHC.Utils.Outputable import GHC.Data.FastString @@ -120,7 +121,8 @@ toIfaceIdBndr :: Id -> IfaceIdBndr toIfaceIdBndr = toIfaceIdBndrX emptyVarSet toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr -toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar) +toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar) + , occNameFS (getOccName covar) , toIfaceTypeX fr (varType covar) ) @@ -172,8 +174,8 @@ toIfaceTypeX fr ty@(AppTy {}) = toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) (toIfaceTypeX (fr `delVarSet` binderVar b) t) -toIfaceTypeX fr (FunTy { ft_arg = t1, ft_res = t2, ft_af = af }) - = IfaceFunTy af (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) +toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af }) + = IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) @@ -292,9 +294,10 @@ toIfaceCoercionX fr co (toIfaceTypeX fr t2) go (TyConAppCo r tc cos) | tc `hasKey` funTyConKey - , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) - | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) - go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2) + , [_,_,_,_, _] <- cos = pprPanic "toIfaceCoercion" empty + | otherwise = + IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2) go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) (toIfaceCoercionX fr' k) @@ -390,7 +393,7 @@ patSynToIfaceDecl ps , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta , ifPatReqCtxt = tidyToIfaceContext env2 req_theta - , ifPatArgs = map (tidyToIfaceType env2) args + , ifPatArgs = map (tidyToIfaceType env2 . scaledThing) args , ifPatTy = tidyToIfaceType env2 rhs_ty , ifFieldLabels = (patSynFieldLabels ps) } diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 44e34aedbf..e846e29ecf 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -33,6 +33,7 @@ import GHC.Core.Lint ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Types.Literal import GHC.Core.Coercion import GHC.Tc.Utils.Env @@ -920,7 +921,7 @@ cpeApp top_env expr case splitFunTy_maybe fun_ty of Just as -> as Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr) - (fs, arg') <- cpeArg top_env ss1 arg arg_ty + (fs, arg') <- cpeArg top_env ss1 arg (scaledThing arg_ty) rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest CpeCast co -> let ty2 = coercionRKind co @@ -1252,7 +1253,7 @@ tryEtaReducePrep bndrs expr@(App _ _) ok _ _ = False -- We can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) = not (hasNoBinding f) + ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f)) ok_to_eta_reduce _ = False -- Safe. ToDo: generalise @@ -1687,7 +1688,7 @@ newVar :: Type -> UniqSM Id newVar ty = seqType ty `seq` do uniq <- getUniqueM - return (mkSysLocalOrCoVar (fsLit "sat") uniq ty) + return (mkSysLocalOrCoVar (fsLit "sat") uniq Many ty) ------------------------------------------------------------------------------ diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 8c1b090023..5f4d14723e 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -121,6 +121,7 @@ data GeneralFlag | Opt_D_faststring_stats | Opt_D_dump_minimal_imports | Opt_DoCoreLinting + | Opt_DoLinearCoreLinting | Opt_DoStgLinting | Opt_DoCmmLinting | Opt_DoAsmLinting diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 16de0ee89a..51a90138b3 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2807,6 +2807,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_rtti) , make_ord_flag defGhcFlag "dcore-lint" (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dlinear-core-lint" + (NoArg (setGeneralFlag Opt_DoLinearCoreLinting)) , make_ord_flag defGhcFlag "dstg-lint" (NoArg (setGeneralFlag Opt_DoStgLinting)) , make_ord_flag defGhcFlag "dcmm-lint" @@ -3805,6 +3807,7 @@ xFlagsDeps = [ flagSpec "KindSignatures" LangExt.KindSignatures, flagSpec "LambdaCase" LangExt.LambdaCase, flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, + flagSpec "LinearTypes" LangExt.LinearTypes, flagSpec "MagicHash" LangExt.MagicHash, flagSpec "MonadComprehensions" LangExt.MonadComprehensions, depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring @@ -3957,6 +3960,7 @@ default_PIC platform = impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) ] ++ validHoleFitsImpliedGFlags @@ -5207,6 +5211,7 @@ initSDocContext dflags style = SDC , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags + , sdocLinearTypes = xopt LangExt.LinearTypes dflags , sdocDynFlags = dflags } diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 01aaf82f20..e25194c240 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -1893,7 +1893,7 @@ substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst | otherwise = ictxt { ic_tythings = map subst_ty tts } where subst_ty (AnId id) - = AnId $ id `setIdType` substTyAddInScope subst (idType id) + = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id -- Variables in the interactive context *can* mention free type variables -- because of the runtime debugger. Otherwise you'd expect all -- variables bound in the interactive context to be closed. diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index fe5eaa84e7..4b8f4228ec 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -1555,7 +1555,7 @@ or contexts in two parts: -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass - = HsConDetails (LBangType pass) (Located [LConDeclField pass]) + = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass]) getConNames :: ConDecl GhcRn -> [Located Name] getConNames ConDeclH98 {con_name = name} = [name] @@ -1564,10 +1564,16 @@ getConNames ConDeclGADT {con_names = names} = names getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn getConArgs d = con_args d -hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] +hsConDeclArgTys :: HsConDeclDetails pass -> [HsScaled pass (LBangType pass)] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) +hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds) + -- Remark: with the record syntax, constructors have all their argument + -- linear, despite the fact that projections do not make sense on linear + -- constructors. The design here is that the record projection themselves are + -- typed to take an unrestricted argument (that is the record itself is + -- unrestricted). By the transfer property, projections are then correct in + -- that all the non-projected fields have multiplicity Many, and can be dropped. hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] hsConDeclTheta Nothing = [] @@ -1643,9 +1649,13 @@ pprConDecl (ConDeclH98 { con_name = L _ con , pprHsForAll (mkHsForAllInvisTele ex_tvs) cxt , ppr_details args ] where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] + -- In ppr_details: let's not print the multiplicities (they are always 1, by + -- definition) as they do not appear in an actual declaration. + ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1), + pprInfixOcc con, + ppr (hsScaledThing t2)] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con - : map (pprHsType . unLoc) tys) + : map (pprHsType . unLoc . hsScaledThing) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) cxt = fromMaybe noLHsContext mcxt diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 28eff0b6c9..d2b30273aa 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -12,6 +12,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} @@ -1573,7 +1574,7 @@ data MatchGroup p body data MatchGroupTc = MatchGroupTc - { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn + { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn , mg_res_ty :: Type -- Type of the result, tr } deriving Data @@ -1851,9 +1852,9 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- For details on above see note [Api annotations] in GHC.Parser.Annotation | BindStmt (XBindStmt idL idR body) -- ^ Post renaming has optional fail and bind / (>>=) operator. - -- Post typechecking, also has result type of the - -- function passed to bind; that is, S in (>>=) - -- :: Q -> (R -> S) -> T + -- Post typechecking, also has multiplicity of the argument + -- and the result type of the function passed to bind; + -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T -- See Note [The type of bind in Stmts] (LPat idL) body @@ -1980,6 +1981,7 @@ data XBindStmtRn = XBindStmtRn data XBindStmtTc = XBindStmtTc { xbstc_bindOp :: SyntaxExpr GhcTc , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S , xbstc_failOp :: FailOperator GhcTc } diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index e49406d484..c66488e770 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -415,6 +415,16 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsArrow p) +deriving instance Data (HsArrow GhcPs) +deriving instance Data (HsArrow GhcRn) +deriving instance Data (HsArrow GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsScaled p a) +deriving instance Data thing => Data (HsScaled GhcPs thing) +deriving instance Data thing => Data (HsScaled GhcRn thing) +deriving instance Data thing => Data (HsScaled GhcTc thing) + deriving instance Data (LHsTypeArg GhcPs) deriving instance Data (LHsTypeArg GhcRn) deriving instance Data (LHsTypeArg GhcTc) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index d09de98950..7ee898a90f 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -17,8 +17,15 @@ GHC.Hs.Type: Abstract syntax: user-defined types {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Hs.Type ( + Mult, HsScaled(..), + hsMult, hsScaledThing, + HsArrow(..), arrowToHsType, + hsLinear, hsUnrestricted, isUnrestricted, + HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), @@ -88,7 +95,7 @@ import GHC.Types.Name( Name, NamedThing(getName) ) import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) -import GHC.Builtin.Types( mkTupleStr ) +import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) import GHC.Core.Type import GHC.Hs.Doc import GHC.Types.Basic @@ -717,6 +724,7 @@ data HsType pass (LHsKind pass) | HsFunTy (XFunTy pass) + (HsArrow pass) (LHsType pass) -- function type (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', @@ -911,6 +919,62 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data +oneDataConHsTy :: HsType GhcRn +oneDataConHsTy = HsTyVar noExtField NotPromoted (noLoc oneDataConName) + +manyDataConHsTy :: HsType GhcRn +manyDataConHsTy = HsTyVar noExtField NotPromoted (noLoc manyDataConName) + +isUnrestricted :: HsArrow GhcRn -> Bool +isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName +isUnrestricted _ = False + +-- | Denotes the type of arrows in the surface language +data HsArrow pass + = HsUnrestrictedArrow + -- ^ a -> b + | HsLinearArrow + -- ^ a #-> b + | HsExplicitMult (LHsType pass) + -- ^ a # m -> b (very much including `a # Many -> b`! This is how the + -- programmer wrote it). It is stored as an `HsType` so as to preserve the + -- syntax as written in the program. + +-- | Convert an arrow into its corresponding multiplicity. In essence this +-- erases the information of whether the programmer wrote an explicit +-- multiplicity or a shorthand. +arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn +arrowToHsType HsUnrestrictedArrow = noLoc manyDataConHsTy +arrowToHsType HsLinearArrow = noLoc oneDataConHsTy +arrowToHsType (HsExplicitMult p) = p + +-- | This is used in the syntax. In constructor declaration. It must keep the +-- arrow representation. +data HsScaled pass a = HsScaled (HsArrow pass) a + +hsMult :: HsScaled pass a -> HsArrow pass +hsMult (HsScaled m _) = m + +hsScaledThing :: HsScaled pass a -> a +hsScaledThing (HsScaled _ t) = t + +-- | When creating syntax we use the shorthands. It's better for printing, also, +-- the shorthands work trivially at each pass. +hsUnrestricted, hsLinear :: a -> HsScaled pass a +hsUnrestricted = HsScaled HsUnrestrictedArrow +hsLinear = HsScaled HsLinearArrow + +instance Outputable a => Outputable (HsScaled pass a) where + ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t + ppr t + +instance + (OutputableBndrId pass) => + Outputable (HsArrow (GhcPass pass)) where + ppr HsUnrestrictedArrow = parens arrow + ppr HsLinearArrow = parens lollipop + ppr (HsExplicitMult p) = parens (mulArrow (ppr p)) + {- Note [Unit tuples] @@ -1264,13 +1328,13 @@ mkHsAppKindTy ext ty k -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) -splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) +splitHsFunType :: LHsType GhcRn -> ([HsScaled GhcRn (LHsType GhcRn)], LHsType GhcRn) splitHsFunType (L _ (HsParTy _ ty)) = splitHsFunType ty -splitHsFunType (L _ (HsFunTy _ x y)) +splitHsFunType (L _ (HsFunTy _ mult x y)) | (args, res) <- splitHsFunType y - = (x:args, res) + = (HsScaled mult x:args, res) splitHsFunType other = ([], other) @@ -1729,7 +1793,7 @@ ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds ppr_mono_ty (HsTyVar _ prom (L _ name)) | isPromoted prom = quote (pprPrefixOcc name) | otherwise = pprPrefixOcc name -ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 +ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2 ppr_mono_ty (HsTupleTy _ con tys) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Solo x`, not `(x)` @@ -1787,12 +1851,16 @@ ppr_mono_ty (XHsType t) = ppr t -------------------------- ppr_fun_ty :: (OutputableBndrId p) - => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc -ppr_fun_ty ty1 ty2 + => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty mult ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 + arr = case mult of + HsLinearArrow -> lollipop + HsUnrestrictedArrow -> arrow + HsExplicitMult p -> mulArrow (ppr p) in - sep [p1, arrow <+> p2] + sep [p1, arr <+> p2] -------------------------- ppr_tylit :: HsTyLit -> SDoc @@ -1851,7 +1919,7 @@ lhsTypeHasLeadingPromotionQuote ty go (HsBangTy{}) = False go (HsRecTy{}) = False go (HsTyVar _ p _) = isPromoted p - go (HsFunTy _ arg _) = goL arg + go (HsFunTy _ _ arg _) = goL arg go (HsListTy{}) = False go (HsTupleTy{}) = False go (HsSumTy{}) = False diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 7ca2d0025b..6cad3c71e9 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -23,6 +23,7 @@ just attach noSrcSpan to everything. {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} @@ -120,6 +121,7 @@ import GHC.Types.Var import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) +import GHC.Core.Multiplicity ( pattern One, pattern Many ) import GHC.Builtin.Types ( unitTy ) import GHC.Tc.Utils.TcType import GHC.Core.DataCon @@ -330,7 +332,10 @@ mkBodyStmt body = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr mkPsBindStmt pat body = BindStmt noExtField pat body mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body -mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType =unitTy, xbstc_failOp = Nothing }) pat body +mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, + xbstc_boundResultType = unitTy, + xbstc_boundResultMult = Many, + xbstc_failOp = Nothing }) pat body -- don't use placeHolderTypeTc above, because that panics during zonking emptyRecStmt' :: forall idL idR body. IsPass idR @@ -516,12 +521,12 @@ nlList exprs = noLoc (ExplicitList noExtField Nothing exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) -nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) +nlHsFunTy mult a b = noLoc (HsFunTy noExtField mult (parenthesizeHsType funPrec a) b) nlHsParTy t = noLoc (HsParTy noExtField t) nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p) @@ -685,9 +690,9 @@ typeToLHsType ty = go ty where go :: Type -> LHsType GhcPs - go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + go ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) = case af of - VisArg -> nlHsFunTy (go arg) (go res) + VisArg -> nlHsFunTy (multToHsArrow mult) (go arg) (go res) InvisArg | (theta, tau) <- tcSplitPhiTy ty -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) , hst_xqual = noExtField @@ -755,6 +760,16 @@ typeToLHsType ty (noLoc (getRdrName tv)) (go (tyVarKind tv)) +-- | This is used to transform an arrow from Core's Type to surface +-- syntax. There is a choice between being very explicit here, or trying to +-- refold arrows into shorthands as much as possible. We choose to do the +-- latter, for it should be more readable. It also helps printing Haskell'98 +-- code into Haskell'98 syntax. +multToHsArrow :: Mult -> HsArrow GhcPs +multToHsArrow One = HsLinearArrow +multToHsArrow Many = HsUnrestrictedArrow +multToHsArrow ty = HsExplicitMult (typeToLHsType ty) + {- Note [Kind signatures in typeToLHsType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index c7ebb509f9..9297d1e4a0 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -43,6 +43,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl +import GHC.Core.Multiplicity import GHC.Builtin.Names import GHC.Builtin.Types.Prim import GHC.Core.Coercion @@ -691,11 +692,11 @@ mkUnsafeCoercePrimPair _old_id old_expr , openAlphaTyVar, openBetaTyVar , x ] $ mkSingleAltCase scrut1 - (mkWildValBinder scrut1_ty) + (mkWildValBinder Many scrut1_ty) (DataAlt unsafe_refl_data_con) [rr_cv] $ mkSingleAltCase scrut2 - (mkWildValBinder scrut2_ty) + (mkWildValBinder Many scrut2_ty) (DataAlt unsafe_refl_data_con) [ab_cv] $ Var x `mkCast` x_co @@ -736,7 +737,7 @@ mkUnsafeCoercePrimPair _old_id old_expr ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] $ - mkVisFunTy openAlphaTy openBetaTy + mkVisFunTyMany openAlphaTy openBetaTy id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info ; return (id, old_expr) } diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 444989a18e..a6c553ec1b 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -38,6 +38,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalB import GHC.Tc.Utils.TcType import GHC.Core.Type( splitPiTy ) +import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Core import GHC.Core.FVs @@ -107,7 +108,7 @@ mkCmdEnv tc_meths where mk_bind (std_name, expr) = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) + ; id <- newSysLocalDs Many (exprType rhs) -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } @@ -175,18 +176,18 @@ mkFailExpr ctxt ty -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a mkFstExpr :: Type -> Type -> DsM CoreExpr mkFstExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + a_var <- newSysLocalDs Many a_ty + b_var <- newSysLocalDs Many b_ty + pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var a_var))) -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b mkSndExpr :: Type -> Type -> DsM CoreExpr mkSndExpr a_ty b_ty = do - a_var <- newSysLocalDs a_ty - b_var <- newSysLocalDs b_ty - pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + a_var <- newSysLocalDs Many a_ty + b_var <- newSysLocalDs Many b_ty + pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var b_var))) @@ -264,9 +265,9 @@ matchEnvStack :: [Id] -- x1..xn -> DsM CoreExpr matchEnvStack env_ids stack_id body = do uniqs <- newUniqueSupply - tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) + pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) ---------------------------------------------- @@ -283,7 +284,7 @@ matchEnv :: [Id] -- x1..xn -> DsM CoreExpr matchEnv env_ids body = do uniqs <- newUniqueSupply - tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) ---------------------------------------------- @@ -298,7 +299,7 @@ matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) matchVarStack [] stack_id body = return (stack_id, body) matchVarStack (param_id:param_ids) stack_id body = do (tail_id, tail_code) <- matchVarStack param_ids stack_id body - pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) + pair_id <- newSysLocalDs Many (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc @@ -326,7 +327,7 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr ProcExpr env_stk_ty - var <- selectSimpleMatchVarL pat + var <- selectSimpleMatchVarL Many pat match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty @@ -375,7 +376,7 @@ dsCmd ids local_vars stack_ty res_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty core_arrow <- dsLExprNoLP arrow core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty + stack_id <- newSysLocalDs Many stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg return (do_premap ids (envStackType env_ids stack_ty) @@ -401,7 +402,7 @@ dsCmd ids local_vars stack_ty res_ty core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_id <- newSysLocalDs stack_ty + stack_id <- newSysLocalDs Many stack_ty core_make_pair <- matchEnvStack env_ids stack_id (mkCorePairExpr core_arrow core_arg) @@ -428,8 +429,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do stack_ty' = mkCorePairTy arg_ty stack_ty (core_cmd, free_vars, env_ids') <- dsfixCmd ids local_vars stack_ty' res_ty cmd - stack_id <- newSysLocalDs stack_ty - arg_id <- newSysLocalDsNoLP arg_ty + stack_id <- newSysLocalDs Many stack_ty + arg_id <- newSysLocalDsNoLP Many arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id) @@ -474,7 +475,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd - stack_id <- newSysLocalDs stack_ty + stack_id <- newSysLocalDs Many stack_ty either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName @@ -538,7 +539,7 @@ dsCmd ids local_vars stack_ty res_ty , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do - stack_id <- newSysLocalDs stack_ty + stack_id <- newSysLocalDs Many stack_ty -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -594,8 +595,8 @@ dsCmd ids local_vars stack_ty res_ty exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars) dsCmd ids local_vars stack_ty res_ty - (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [arg_ty] _ }) env_ids = do - arg_id <- newSysLocalDs arg_ty + (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do + arg_id <- newSysLocalDs arg_mult arg_ty let case_cmd = noLoc $ HsCmdCase noExtField (nlHsVar arg_id) mg dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids @@ -613,7 +614,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body - stack_id <- newSysLocalDs stack_ty + stack_id <- newSysLocalDs Many stack_ty -- build a new environment, plus the stack, using the let bindings core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) -- match the old environment and stack against the input @@ -684,7 +685,7 @@ dsTrimCmdArg local_vars env_ids (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd - stack_id <- newSysLocalDs stack_ty + stack_id <- newSysLocalDs Many stack_ty trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) let @@ -750,8 +751,8 @@ dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDsNoLP pat_tys - stack_id' <- newSysLocalDs stack_ty' + param_ids <- mapM (newSysLocalDsNoLP Many) pat_tys + stack_id' <- newSysLocalDs Many stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -801,7 +802,7 @@ dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids - env_var <- newSysLocalDs env_ty + env_var <- newSysLocalDs Many env_ty let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) return (do_premap ids env_ty @@ -904,7 +905,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do -- projection function -- \ (p, (xs2)) -> (zs) - env_id <- newSysLocalDs env_ty2 + env_id <- newSysLocalDs Many env_ty2 uniqs <- newUniqueSupply let after_c_ty = mkCorePairTy pat_ty env_ty2 @@ -912,10 +913,10 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty - pat_id <- selectSimpleMatchVarL pat + pat_id <- selectSimpleMatchVarL Many pat match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr - pair_id <- newSysLocalDs after_c_ty + pair_id <- newSysLocalDs Many after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -978,7 +979,7 @@ dsCmdStmt ids local_vars out_ids -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) uniqs <- newUniqueSupply - env2_id <- newSysLocalDs env2_ty + env2_id <- newSysLocalDs Many env2_ty let later_ty = mkBigCoreVarTupTy later_ids post_pair_ty = mkCorePairTy later_ty env2_ty @@ -1065,7 +1066,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - rec_id <- newSysLocalDs rec_ty + rec_id <- newSysLocalDs Many rec_ty let env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set env1_ids = dVarSetElems env1_id_set diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 8b53e87641..dd4b76f945 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -53,6 +53,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.Multiplicity import GHC.Builtin.Types ( typeNatKind, typeSymbolKind ) import GHC.Types.Id import GHC.Types.Id.Make(proxyHashId) @@ -176,7 +177,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun = [] ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) -- , ppr (mg_alts matches) - -- , ppr args, ppr core_binds]) $ + -- , ppr args, ppr core_binds, ppr body']) $ return (force_var, [core_binds]) } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss @@ -288,7 +289,7 @@ dsAbsBinds dflags tyvars dicts exports mkLet core_bind $ tup_expr - ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) + ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs) -- Find corresponding global or make up a new one: sometimes -- we need to make new export to desugar strict binds, see @@ -299,7 +300,7 @@ dsAbsBinds dflags tyvars dicts exports , abe_poly = global , abe_mono = local, abe_prags = spec_prags }) -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds" - = do { tup_id <- newSysLocalDs tup_ty + = do { tup_id <- newSysLocalDs Many tup_ty ; core_wrap <- dsHsWrapper wrap ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ mkTupleSelector all_locals local tup_id $ @@ -357,7 +358,7 @@ dsAbsBinds dflags tyvars dicts exports ([],[]) lcls mk_export local = - do global <- newSysLocalDs + do global <- newSysLocalDs Many (exprType (mkLams tyvars (mkLams dicts (Var local)))) return (ABE { abe_ext = noExtField , abe_poly = global @@ -703,7 +704,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf - spec_id = mkLocalId spec_name spec_ty + spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many. `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -876,7 +877,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs = scopedSort unbound_tvs ++ unbound_dicts where unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] - unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d) + unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (idType d) | d <- unbound_vars, isDictId d ] unbound_vars = [ v | v <- exprsFreeVarsList args , not (v `elemVarSet` orig_bndr_set) @@ -1126,8 +1127,8 @@ dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 ; return (w1 . w2) } -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what -- the specification of this clause is -dsHsWrapper (WpFun c1 c2 t1 doc) - = do { x <- newSysLocalDsNoLP t1 +dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc) + = do { x <- newSysLocalDsNoLP w t1 ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a @@ -1140,7 +1141,9 @@ dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm ; return (\e -> App e core_tm) } - +dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ + errDs (text "Multiplicity coercions are currently not supported") + ; return $ \e -> e } -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] dsTcEvBinds_s [] = return [] @@ -1264,24 +1267,26 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) ; mkTrApp <- dsLookupGlobalId mkTrAppName -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b) - ; let (k1, k2) = splitFunTy (typeKind t1) + ; let (Scaled _ k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, + -- since it's a kind ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) [ e1, e2 ] -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr ; return expr } -ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) - | Just (t1,t2) <- splitFunTy_maybe ty +ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) + | Just (Scaled m t1,t2) <- splitFunTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2 + ; em <- getRep evm m ; mkTrFun <- dsLookupGlobalId mkTrFunName - -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). - -- TypeRep a -> TypeRep b -> TypeRep (a -> b) + -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a # m -> b) ; let r1 = getRuntimeRep t1 r2 = getRuntimeRep t2 - ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) - [ e1, e2 ] + ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2]) + [ em, e1, e2 ] } ds_ev_typeable ty (EvTypeableTyLit ev) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 816768cc09..e84104a68d 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -712,6 +712,7 @@ addTickStmt _isGuard (BindStmt xbs pat e) = do liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs + , xbstc_boundResultMult = xbstc_boundResultMult xbs , xbstc_failOp = f }) (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs)) diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index d37c2dccaf..2cbc95c7b8 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -206,8 +206,9 @@ subordinates instMap decl = case decl of -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map unLoc args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1), + unLoc (hsScaledThing arg2)] ++ ret) RecCon _ -> go 1 ret where go n = M.fromList . catMaybes . zipWith f [n..] @@ -260,12 +261,12 @@ typeDocs :: HsType GhcRn -> Map Int (HsDocString) typeDocs = go 0 where go n = \case - HsForAllTy { hst_body = ty } -> go n (unLoc ty) - HsQualTy { hst_body = ty } -> go n (unLoc ty) - HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) - HsFunTy _ _ ty -> go (n+1) (unLoc ty) - HsDocTy _ _ doc -> M.singleton n (unLoc doc) - _ -> M.empty + HsForAllTy { hst_body = ty } -> go n (unLoc ty) + HsQualTy { hst_body = ty } -> go n (unLoc ty) + HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) + HsFunTy _ _ _ ty -> go (n+1) (unLoc ty) + HsDocTy _ _ doc -> M.singleton n (unLoc doc) + _ -> M.empty -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 5e71fabb68..4fbfbc7d62 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -45,6 +45,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core import GHC.Core.Utils import GHC.Core.Make @@ -63,6 +64,7 @@ import GHC.Types.Basic import GHC.Data.Maybe import GHC.Types.Var.Env import GHC.Types.SrcLoc +import GHC.Builtin.Types.Prim ( mkTemplateTyVars ) import GHC.Utils.Misc import GHC.Data.Bag import GHC.Utils.Outputable as Outputable @@ -220,7 +222,9 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource, eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar upat + ; var <- selectMatchVar Many upat + -- `var` will end up in a let binder, so the multiplicity + -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) ; return (bindNonRec var rhs result) } @@ -398,7 +402,7 @@ dsExpr e@(SectionL _ expr op) = do -- Binary operator section (x_ty:y_ty:_, _) -> do dsWhenNoErrs - (mapM newSysLocalDsNoLP [x_ty, y_ty]) + (newSysLocalsDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> bindNonRec x_id x_core $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e) @@ -417,26 +421,31 @@ dsExpr e@(SectionR _ op expr) = do core_op <- dsLExpr op let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) y_core <- dsLExpr expr - dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) + dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> bindNonRec y_id y_core $ Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) dsExpr (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing ty)) + = do { let go (lam_vars, args, usedmults, mult:mults) (L _ (Missing ty)) -- For every missing expression, we need - -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDsNoLP ty - ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present _ expr)) + -- another lambda in the desugaring. This lambda is linear + -- since tuples are linear + = do { lam_var <- newSysLocalDsNoLP (mkTyVarTy mult) ty + ; return (lam_var : lam_vars, Var lam_var : args, mult:usedmults, mults) } + go (lam_vars, args, missing, mults) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr - ; return (lam_vars, core_expr : args) } + ; return (lam_vars, core_expr : args, missing, mults) } + go (lam_vars, args, missing, mults) _ = pprPanic "dsExpr" (ppr lam_vars <+> ppr args <+> ppr missing <+> ppr mults) - ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) + ; let multiplicityVars = mkTemplateTyVars (repeat multiplicityTy) + ; dsWhenNoErrs (foldM go ([], [], [], multiplicityVars) (reverse tup_args)) -- The reverse is because foldM goes left-to-right - (\(lam_vars, args) -> mkCoreLams lam_vars $ + (\(lam_vars, args, usedmults, _) -> + mkCoreLams usedmults $ + mkCoreLams lam_vars $ mkCoreTupBoxity boxity args) } -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make @@ -581,8 +590,8 @@ dsExpr (RecordCon { rcon_flds = rbinds labels = conLikeFieldLabels con_like ; con_args <- if null labels - then mapM unlabelled_bottom arg_tys - else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) + then mapM unlabelled_bottom (map scaledThing arg_tys) + else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels) ; return (mkCoreApps con_expr' con_args) } @@ -646,8 +655,9 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields ; ([discrim_var], matching_code) <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] (MG { mg_alts = noLoc alts - , mg_ext = MatchGroupTc [in_ty] out_ty - , mg_origin = FromSource }) + , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty + , mg_origin = FromSource + }) -- FromSource is not strictly right, but we -- want incomplete pattern-match warnings @@ -662,7 +672,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idType fld_id) + ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id) ; return (idName fld_id, lcl_id, rhs) } add_field_binds [] expr = expr @@ -681,6 +691,9 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con + arg_tys' = map (scaleScaled Many) arg_tys + -- Record updates consume the source record with multiplicity + -- Many. Therefore all the fields need to be scaled thus. user_tvs = binderVars $ conLikeUserTyVarBinders con in_subst = zipTvSubst univ_tvs in_inst_tys out_subst = zipTvSubst univ_tvs out_inst_tys @@ -688,7 +701,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) - ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys) + ; arg_ids <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys') ; let field_labels = conLikeFieldLabels con val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg field_labels arg_ids @@ -979,7 +992,7 @@ dsDo stmts go _ (BindStmt xbs pat rhs) stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL pat + ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat (xbstc_boundResultType xbs) (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs) @@ -1000,7 +1013,7 @@ dsDo stmts ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) ; let match_args (pat, fail_op) (vs,body) - = do { var <- selectSimpleMatchVarL pat + = do { var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure pat match fail_op @@ -1028,6 +1041,7 @@ dsDo stmts XBindStmtTc { xbstc_bindOp = bind_op , xbstc_boundResultType = bind_ty + , xbstc_boundResultMult = Many , xbstc_failOp = Nothing -- Tuple cannot fail } (mkBigLHsPatTupId later_pats) @@ -1043,7 +1057,7 @@ dsDo stmts (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_ext = MatchGroupTc [tup_ty] body_ty + , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLoc $ HsDo body_ty diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index fbe9c424bc..69639268ea 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -37,6 +37,7 @@ import GHC.HsToCore.Utils import GHC.Tc.Utils.TcType import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Types.Id ( Id ) import GHC.Core.Coercion import GHC.Builtin.PrimOps @@ -125,7 +126,7 @@ mkFCall dflags uniq the_fcall val_args res_ty mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args - body_ty = (mkVisFunTys arg_tys res_ty) + body_ty = (mkVisFunTysMany arg_tys res_ty) tyvars = tyCoVarsOfTypeWellScoped body_ty ty = mkInfForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty @@ -154,7 +155,7 @@ unboxArg arg tc `hasKey` boolTyConKey = do dflags <- getDynFlags let platform = targetPlatform dflags - prim_arg <- newSysLocalDs intPrimTy + prim_arg <- newSysLocalDs Many intPrimTy return (Var prim_arg, \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg @@ -166,8 +167,8 @@ unboxArg arg | is_product_type && data_con_arity == 1 = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty) -- Typechecker ensures this - do case_bndr <- newSysLocalDs arg_ty - prim_arg <- newSysLocalDs data_con_arg_ty1 + do case_bndr <- newSysLocalDs Many arg_ty + prim_arg <- newSysLocalDs Many data_con_arg_ty1 return (Var prim_arg, \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] ) @@ -181,8 +182,8 @@ unboxArg arg isJust maybe_arg3_tycon && (arg3_tycon == byteArrayPrimTyCon || arg3_tycon == mutableByteArrayPrimTyCon) - = do case_bndr <- newSysLocalDs arg_ty - vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + = do case_bndr <- newSysLocalDs Many arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) return (Var arr_cts_var, \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] ) @@ -194,7 +195,8 @@ unboxArg arg arg_ty = exprType arg maybe_product_type = splitDataProductType_maybe arg_ty is_product_type = isJust maybe_product_type - Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type + data_con_arg_tys = map scaledThing scaled_data_con_arg_tys data_con_arity = dataConSourceArity data_con (data_con_arg_ty1 : _) = data_con_arg_tys @@ -240,7 +242,7 @@ boxResult result_ty ; (ccall_res_ty, the_alt) <- mk_alt return_result res - ; state_id <- newSysLocalDs realWorldStatePrimTy + ; state_id <- newSysLocalDs Many realWorldStatePrimTy ; let io_data_con = head (tyConDataCons io_tycon) toIOCon = dataConWrapId io_data_con @@ -249,12 +251,12 @@ boxResult result_ty [ Type io_res_ty, Lam state_id $ mkWildCase (App the_call (Var state_id)) - ccall_res_ty + (unrestricted ccall_res_ty) (coreAltType the_alt) [the_alt] ] - ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) } + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } boxResult result_ty = do -- It isn't IO, so do unsafePerformIO @@ -263,10 +265,10 @@ boxResult result_ty (ccall_res_ty, the_alt) <- mk_alt return_result res let wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) - ccall_res_ty + (unrestricted ccall_res_ty) (coreAltType the_alt) [the_alt] - return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) where return_result _ [ans] = ans return_result _ _ = panic "return_result: expected single result" @@ -277,7 +279,7 @@ mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) -> DsM (Type, (AltCon, [Id], Expr Var)) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns () - state_id <- newSysLocalDs realWorldStatePrimTy + state_id <- newSysLocalDs Many realWorldStatePrimTy let the_rhs = return_result (Var state_id) [wrap_result (panic "boxResult")] @@ -291,8 +293,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result) = -- The ccall returns a non-() value ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty ) -- True because resultWrapper ensures it is so - do { result_id <- newSysLocalDs prim_res_ty - ; state_id <- newSysLocalDs realWorldStatePrimTy + do { result_id <- newSysLocalDs Many prim_res_ty + ; state_id <- newSysLocalDs Many realWorldStatePrimTy ; let the_rhs = return_result (Var state_id) [wrap_result (Var result_id)] ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] @@ -322,7 +324,7 @@ resultWrapper result_ty -- Base case 2: the unit type () | Just (tc,_) <- maybe_tc_app , tc `hasKey` unitTyConKey - = return (Nothing, \_ -> Var unitDataConId) + = return (Nothing, \_ -> unitExpr) -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app @@ -330,7 +332,7 @@ resultWrapper result_ty = do { dflags <- getDynFlags ; let platform = targetPlatform dflags ; let marshal_bool e - = mkWildCase e intPrimTy boolTy + = mkWildCase e (unrestricted intPrimTy) boolTy [ (DEFAULT ,[],Var trueDataConId ) , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) } @@ -350,7 +352,7 @@ resultWrapper result_ty -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys) <- maybe_tc_app , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials - , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument + , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument = do { dflags <- getDynFlags ; let platform = targetPlatform dflags ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 9ed161f18b..71d9eff7f2 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -36,6 +36,7 @@ import GHC.Core.Type import GHC.Types.RepType import GHC.Core.TyCon import GHC.Core.Coercion +import GHC.Core.Multiplicity import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType @@ -257,7 +258,7 @@ dsFCall fn_id co fcall mDeclHeader = do mHeadersArgTypeList = [ (header, cType <+> char 'a' <> int n) | (t, n) <- zip arg_tys [1..] - , let (header, cType) = toCType t ] + , let (header, cType) = toCType (scaledThing t) ] (mHeaders, argTypeList) = unzip mHeadersArgTypeList argTypes = if null argTypeList then text "void" @@ -272,11 +273,11 @@ dsFCall fn_id co fcall mDeclHeader = do return (fcall, empty) let -- Build the worker - worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty) + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) tvs = map binderVar tv_bndrs the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty + work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args @@ -428,14 +429,14 @@ dsFExportDynamic id co0 cconv = do (moduleStableString mod ++ "$" ++ toCName dflags id) -- Construct the label based on the passed id, don't use names -- depending on Unique. See #13807 and Note [Unique Determinism]. - cback <- newSysLocalDs arg_ty + cback <- newSysLocalDs arg_mult arg_ty newStablePtrId <- dsLookupGlobalId newStablePtrName stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName let stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] - export_ty = mkVisFunTy stable_ptr_ty arg_ty + export_ty = mkVisFunTyMany stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName - stbl_value <- newSysLocalDs stable_ptr_ty + stbl_value <- newSysLocalDs Many stable_ptr_ty (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True let {- @@ -482,7 +483,7 @@ dsFExportDynamic id co0 cconv = do where ty = coercionLKind co0 (tvs,sans_foralls) = tcSplitForAllTys ty - ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty -- Must have an IO type; hence Just @@ -813,7 +814,7 @@ getPrimTyOf ty -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). | otherwise = case splitDataProductType_maybe rep_ty of - Just (_, _, data_con, [prim_ty]) -> + Just (_, _, data_con, [Scaled _ prim_ty]) -> ASSERT(dataConSourceArity data_con == 1) ASSERT2(isUnliftedType prim_ty, ppr prim_ty) prim_ty diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 68162187b8..8a991e9ceb 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -30,6 +30,7 @@ import GHC.Core.Type ( Type ) import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable +import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList ) @@ -124,7 +125,10 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do let upat = unLoc pat - match_var <- selectMatchVar upat + match_var <- selectMatchVar Many upat + -- We only allow unrestricted patterns in guard, hence the `Many` + -- above. It isn't clear what linear patterns would mean, maybe we will + -- figure it out in the future. match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 9d6a9bb462..05b1ce73fe 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -30,6 +30,7 @@ import GHC.Driver.Session import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Builtin.Types import GHC.HsToCore.Match import GHC.Builtin.Names @@ -278,11 +279,11 @@ deBindComp pat core_list1 quals core_list2 = do let u2_ty = hsLPatType pat let res_ty = exprType core_list2 - h_ty = u1_ty `mkVisFunTy` res_ty + h_ty = u1_ty `mkVisFunTyMany` res_ty -- no levity polymorphism here, as list comprehensions don't work -- with RebindableSyntax. NB: These are *not* monad comps. - [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] + [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty] -- the "fail" value ... let @@ -371,8 +372,8 @@ dfBindComp c_id n_id (pat, core_list1) quals = do let b_ty = idType n_id -- create some new local id's - b <- newSysLocalDs b_ty - x <- newSysLocalDs x_ty + b <- newSysLocalDs Many b_ty + x <- newSysLocalDs Many x_ty -- build rest of the comprehension core_rest <- dfListComp c_id b quals @@ -402,11 +403,11 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr) -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] mkZipBind elt_tys = do - ass <- mapM newSysLocalDs elt_list_tys - as' <- mapM newSysLocalDs elt_tys - as's <- mapM newSysLocalDs elt_list_tys + ass <- mapM (newSysLocalDs Many) elt_list_tys + as' <- mapM (newSysLocalDs Many) elt_tys + as's <- mapM (newSysLocalDs Many) elt_list_tys - zip_fn <- newSysLocalDs zip_fn_ty + zip_fn <- newSysLocalDs Many zip_fn_ty let inner_rhs = mkConsExpr elt_tuple_ty (mkBigCoreVarTup as') @@ -419,7 +420,7 @@ mkZipBind elt_tys = do elt_tuple_ty = mkBigCoreTupTy elt_tys elt_tuple_list_ty = mkListTy elt_tuple_ty - zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty + zip_fn_ty = mkVisFunTysMany elt_list_tys elt_tuple_list_ty mk_case (as, a', as') rest = Case (Var as) as elt_tuple_list_ty @@ -441,13 +442,13 @@ mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) mkUnzipBind ThenForm _ = return Nothing -- No unzipping for ThenForm mkUnzipBind _ elt_tys - = do { ax <- newSysLocalDs elt_tuple_ty - ; axs <- newSysLocalDs elt_list_tuple_ty - ; ys <- newSysLocalDs elt_tuple_list_ty - ; xs <- mapM newSysLocalDs elt_tys - ; xss <- mapM newSysLocalDs elt_list_tys + = do { ax <- newSysLocalDs Many elt_tuple_ty + ; axs <- newSysLocalDs Many elt_list_tuple_ty + ; ys <- newSysLocalDs Many elt_tuple_list_ty + ; xs <- mapM (newSysLocalDs Many) elt_tys + ; xss <- mapM (newSysLocalDs Many) elt_list_tys - ; unzip_fn <- newSysLocalDs unzip_fn_ty + ; unzip_fn <- newSysLocalDs Many unzip_fn_ty ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] @@ -467,7 +468,7 @@ mkUnzipBind _ elt_tys elt_list_tys = map mkListTy elt_tys elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys - unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty + unzip_fn_ty = elt_tuple_list_ty `mkVisFunTyMany` elt_list_tuple_ty mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail @@ -551,8 +552,8 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' - ; tup_n_var' <- newSysLocalDs tup_n_ty' + ; n_tup_var' <- newSysLocalDsNoLP Many n_tup_ty' + ; tup_n_var' <- newSysLocalDs Many tup_n_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs' @@ -601,7 +602,7 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr -- \x. case x of (a,b,c) -> body matchTuple ids body = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) + ; tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy ids) ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a @@ -615,7 +616,7 @@ dsMcBindStmt :: LPat GhcTc -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL pat + ; var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat res1_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure pat match fail_op @@ -656,9 +657,9 @@ mkMcUnzipM ThenForm _ ys _ mkMcUnzipM _ fmap_op ys elt_tys = do { fmap_op' <- dsExpr fmap_op - ; xs <- mapM newSysLocalDs elt_tys + ; xs <- mapM (newSysLocalDs Many) elt_tys ; let tup_ty = mkBigCoreTupTy elt_tys - ; tup_xs <- newSysLocalDs tup_ty + ; tup_xs <- newSysLocalDs Many tup_ty ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b [ Type tup_ty, Type (getNth elt_tys i) diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 55f2709cf9..dc8f87b91d 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -52,13 +52,14 @@ import GHC.HsToCore.Match.Literal import GHC.Core.Type import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon ) +import GHC.Core.Multiplicity import GHC.Builtin.Types import GHC.Types.SrcLoc import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Name import GHC.Utils.Outputable -import GHC.Types.Basic ( isGenerated, il_value, fl_value ) +import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) ) import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM @@ -171,9 +172,14 @@ See also Note [Localise pattern binders] in GHC.HsToCore.Utils type MatchId = Id -- See Note [Match Ids] -match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids] - -> Type -- ^ Type of the case expression - -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) +match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with + -- ^ See Note [Match Ids] + -- + -- ^ Note that the Match Ids carry not only a name, but + -- ^ also the multiplicity at which each column has been + -- ^ type checked. + -> Type -- ^ Type of the case expression + -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) -> DsM (MatchResult CoreExpr) -- ^ Desugared result! match [] ty eqns @@ -251,7 +257,7 @@ matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr)) matchEmpty var res_ty = return [MR_Fallible mk_seq] where - mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty + mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty [(DEFAULT, [], fail)] matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) @@ -270,7 +276,7 @@ matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (Match matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) = do { let XPat (CoPat co pat _) = firstPat eqn1 ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' + ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getCoPat <$> eqns ; core_wrap <- dsHsWrapper co @@ -286,7 +292,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _)) let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat - ; var' <- newUniqueId var pat_ty' + ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getViewPat <$> eqns -- compile the view expressions @@ -300,7 +306,7 @@ matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 - ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand + ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ NEL.toList $ decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern ; e' <- dsSyntaxExpr e [Var var] @@ -469,12 +475,17 @@ tidy1 _ _ (TuplePat tys pats boxity) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys + tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys' + tys' = case boxity of + Unboxed -> map getRuntimeRep tys ++ tys + Boxed -> tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon tidy1 _ _ (SumPat tys pat alt arity) = return (idDsWrapper, unLoc sum_ConPat) where - sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys + sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys) + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ o (LitPat _ lit) @@ -532,7 +543,7 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc) -- Newtypes: push bang inwards (#9844) = if isNewTyCon (dataConTyCon dc) - then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args }) + then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) else tidy1 v o p -- Data types: discard the bang where (ty:_) = dataConInstArgTys dc arg_tys @@ -745,8 +756,12 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches ; locn <- getSrcSpanDs ; new_vars <- case matches of - [] -> mapM newSysLocalDsNoLP arg_tys - (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) + [] -> newSysLocalsDsNoLP arg_tys + (m:_) -> + selectMatchVars (zipWithEqual "matchWrapper" + (\a b -> (scaledMult a, unLoc b)) + arg_tys + (hsLMatchPats m)) -- Pattern match check warnings for /this match-group/. -- @rhss_deltas@ is a flat list of covered Deltas for each RHS. @@ -846,7 +861,12 @@ matchSinglePat (Var var) ctx pat ty match_result = matchSinglePatVar var ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL pat + = do { var <- selectSimpleMatchVarL Many pat + -- matchSinglePat is only used in matchSimply, which + -- is used in list comprehension, arrow notation, + -- and to create field selectors. All of which only + -- bind unrestricted variables, hence the 'Many' + -- above. ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result ; return $ bindNonRec var scrut <$> match_result' } diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index 9c7ad46c22..96ab10fa4c 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -25,6 +25,7 @@ import GHC.HsToCore.Binds import GHC.Core.ConLike import GHC.Types.Basic ( Origin(..) ) import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core ( CoreExpr ) @@ -98,7 +99,13 @@ matchConFamily :: NonEmpty Id -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily (var :| vars) ty groups - = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups + = do let mult = idMult var + -- Each variable in the argument list correspond to one column in the + -- pattern matching equations. Its multiplicity is the context + -- multiplicity of the pattern. We extract that multiplicity, so that + -- 'matchOneconLike' knows the context multiplicity, in case it needs + -- to come up with new variables. + alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups return (mkCoAlgCaseMatchResult var ty alts) where toRealAlt alt = case alt_pat alt of @@ -110,7 +117,8 @@ matchPatSyn :: NonEmpty Id -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns - = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns + = do let mult = idMult var + alt <- fmap toSynAlt $ matchOneConLike vars ty mult eqns return (mkCoSynCaseMatchResult var ty alt) where toSynAlt alt = case alt_pat alt of @@ -121,9 +129,10 @@ type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) matchOneConLike :: [Id] -> Type + -> Mult -> NonEmpty EquationInfo -> DsM (CaseAlt ConLike) -matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor +matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) -- ex_tvs can only be tyvars as data types in source -- Haskell cannot mention covar yet (Aug 2018). @@ -163,8 +172,15 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor , eqn_pats = conArgPats val_arg_tys args ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) - - ; arg_vars <- selectConMatchVars val_arg_tys args1 + ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys + -- The 'val_arg_tys' are taken from the data type definition, they + -- do not take into account the context multiplicity, therefore we + -- need to scale them back to get the correct context multiplicity + -- to desugar the sub-pattern in each field. We need to know these + -- multiplicity because of the invariant that, in Core, binders in a + -- constructor pattern must be scaled by the multiplicity of the + -- case. See Note [Case expression invariants]. + ; arg_vars <- selectConMatchVars scaled_arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -229,12 +245,15 @@ same_fields flds1 flds2 ----------------- -selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys -selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) -selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] +selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] +selectConMatchVars arg_tys con = case con of + (RecCon {}) -> newSysLocalsDsNoLP arg_tys + (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps) + (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2]) + where + zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) -conArgPats :: [Type] -- Instantiated argument types +conArgPats :: [Scaled Type]-- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats @@ -242,7 +261,7 @@ conArgPats :: [Type] -- Instantiated argument types conArgPats _arg_tys (PrefixCon ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) - | null rpats = map WildPat arg_tys + | null rpats = map WildPat (map scaledThing arg_tys) -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 600af91468..eb8f865aa1 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -39,6 +39,7 @@ import GHC.Core import GHC.Core.Make import GHC.Core.TyCon import GHC.Core.DataCon +import GHC.Core.Multiplicity import GHC.Tc.Utils.Zonk ( shortCutLit ) import GHC.Tc.Utils.TcType import GHC.Types.Name @@ -148,7 +149,7 @@ warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () warnAboutIdentities dflags (Var conv_fn) type_of_conv | wopt Opt_WarnIdentities dflags , idName conv_fn `elem` conversionNames - , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , Just (Scaled _ arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty = warnDs (Reason Opt_WarnIdentities) (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 02bd5cf91e..57eaf15cf8 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -79,6 +79,7 @@ import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env @@ -356,7 +357,7 @@ still reporting nice error messages. -} -- Make a new Id with the same print name, but different type, and new unique -newUniqueId :: Id -> Type -> DsM Id +newUniqueId :: Id -> Mult -> Type -> DsM Id newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id @@ -366,9 +367,9 @@ duplicateLocalDs old_local newPredVarDs :: PredType -> DsM Var newPredVarDs - = mkSysLocalOrCoVarM (fsLit "ds") -- like newSysLocalDs, but we allow covars + = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars -newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDsNoLP = mk_local (fsLit "ds") -- this variant should be used when the caller can be sure that the variable type @@ -379,15 +380,15 @@ newFailLocalDs = mkSysLocalM (fsLit "fail") -- the fail variable is used only in a situation where we can tell that -- levity-polymorphism is impossible. -newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] -newSysLocalsDsNoLP = mapM newSysLocalDsNoLP -newSysLocalsDs = mapM newSysLocalDs +newSysLocalsDsNoLP, newSysLocalsDs :: [Scaled Type] -> DsM [Id] +newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t) +newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t) -mk_local :: FastString -> Type -> DsM Id -mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> - ppr ty) -- could improve the msg with another - -- parameter indicating context - ; mkSysLocalOrCoVarM fs ty } +mk_local :: FastString -> Mult -> Type -> DsM Id +mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> + ppr ty) -- could improve the msg with another + -- parameter indicating context + ; mkSysLocalOrCoVarM fs w ty } {- We can also reach out and either set/grab location information from @@ -561,7 +562,7 @@ discardWarningsDs thing_inside -- | Fail with an error message if the type is levity polymorphic. dsNoLevPoly :: Type -> SDoc -> DsM () -- See Note [Levity polymorphism checking] -dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty +dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty -- | Check an expression for levity polymorphism, failing if it is -- levity polymorphic. diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index f09fd4ecbe..4e96ce35f7 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -57,6 +57,7 @@ import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Core.TyCo.Rep import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.HsToCore.Utils (isTrueLHsExpr) import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -553,7 +554,7 @@ translatePat fam_insts x pat = case pat of -- | 'translatePat', but also select and return a new match var. translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec) translatePatV fam_insts pat = do - x <- selectMatchVar pat + x <- selectMatchVar Many pat grds <- translatePat fam_insts x pat pure (x, grds) @@ -581,7 +582,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs) where -- The actual argument types (instantiated) - arg_tys = conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) + arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) -- Extract record field patterns tagged by field index from a list of -- LHsRecField diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index b16b5e5907..db1975e807 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -68,6 +68,7 @@ import GHC.Utils.Monad hiding (foldlM) import GHC.HsToCore.Monad hiding (foldlM) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv +import GHC.Core.Multiplicity import Control.Monad (guard, mzero, when) import Control.Monad.Trans.Class (lift) @@ -96,7 +97,7 @@ mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" name = mkInternalName unique occname noSrcSpan - in return (mkLocalIdOrCoVar name ty) + in return (mkLocalIdOrCoVar name Many ty) ----------------------------------------------- -- * Caching possible matches of a COMPLETE set @@ -145,7 +146,7 @@ mkOneConFull arg_tys con = do -- Instantiate fresh existentials as arguments to the constructor. This is -- important for instantiating the Thetas and field types. (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM - let field_tys' = substTys subst field_tys + let field_tys' = substTys subst $ map scaledThing field_tys -- Instantiate fresh term variables (VAs) as arguments to the constructor vars <- mapM mkPmId field_tys' -- All constraints bound by the constructor (alpha-renamed), these are added @@ -501,7 +502,7 @@ nameTyCt pred_ty = do unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) idname = mkInternalName unique occname noSrcSpan - return (mkLocalIdOrCoVar idname pred_ty) + return (mkLocalIdOrCoVar idname Many pred_ty) -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@). diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index b1d569e5e0..6aedef187a 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} @@ -52,6 +53,7 @@ import GHC.Types.Name.Env import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Builtin.Types +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core import GHC.Core.Make import GHC.Core.Utils @@ -112,8 +114,8 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) expected_ty = mkInvisForAllTys tyvars $ - mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars))) - (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) + mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars))) + (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty) @@ -1288,9 +1290,10 @@ repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) = repTy ty@(HsQualTy {}) = repForallT ty repTy (HsTyVar _ _ (L _ n)) - | isLiftedTypeKindTyConName n = repTStar - | n `hasKey` constraintKindTyConKey = repTConstraint - | n `hasKey` funTyConKey = repArrowTyCon + | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` constraintKindTyConKey = repTConstraint + | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon + | n `hasKey` funTyConKey = repMulArrowTyCon | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -1309,11 +1312,16 @@ repTy (HsAppKindTy _ ty ki) = do ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1 -repTy (HsFunTy _ f a) = do +repTy (HsFunTy _ w f a) | isUnrestricted w = do f1 <- repLTy f a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1] +repTy (HsFunTy _ w f a) = do w1 <- repLTy (arrowToHsType w) + f1 <- repLTy f + a1 <- repLTy a + tcon <- repMulArrowTyCon + repTapps tcon [w1, f1, a1] repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon @@ -2010,7 +2018,7 @@ mkGenSyms :: [Name] -> MetaM [GenSymBind] -- -- Nevertheless, it's monadic because we have to generate nameTy mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } + ; return [(nm, mkLocalId (localiseName nm) Many var_ty) | nm <- ns] } addBinds :: [GenSymBind] -> MetaM a -> MetaM a @@ -2561,11 +2569,11 @@ repConstr :: HsConDeclDetails GhcRn -> [Core TH.Name] -> MetaM (Core (M TH.Con)) repConstr (PrefixCon ps) Nothing [con] - = do arg_tys <- repListM bangTypeTyConName repBangTy ps + = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) rep2 normalCName [unC con, unC arg_tys] repConstr (PrefixCon ps) (Just res_ty) cons - = do arg_tys <- repListM bangTypeTyConName repBangTy ps + = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) res_ty' <- repLTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] @@ -2588,8 +2596,8 @@ repConstr (RecCon ips) resTy cons ; rep2 varBangTypeName [v,ty] } repConstr (InfixCon st1 st2) Nothing [con] - = do arg1 <- repBangTy st1 - arg2 <- repBangTy st2 + = do arg1 <- repBangTy (hsScaledThing st1) + arg2 <- repBangTy (hsScaledThing st2) rep2 infixCName [unC arg1, unC con, unC arg2] repConstr (InfixCon {}) (Just _) _ = @@ -2677,6 +2685,9 @@ repUnboxedSumTyCon arity = do platform <- getPlatform repArrowTyCon :: MetaM (Core (M TH.Type)) repArrowTyCon = rep2 arrowTName [] +repMulArrowTyCon :: MetaM (Core (M TH.Type)) +repMulArrowTyCon = rep2 mulArrowTName [] + repListTyCon :: MetaM (Core (M TH.Type)) repListTyCon = rep2 listTName [] diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index d7b6d8f358..709a3a1698 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -66,6 +66,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.Coercion import GHC.Builtin.Types.Prim import GHC.Builtin.Types @@ -100,12 +101,13 @@ import qualified Data.List.NonEmpty as NEL We're about to match against some patterns. We want to make some @Ids@ to use as match variables. If a pattern has an @Id@ readily at hand, which should indeed be bound to the pattern as a whole, then use it; -otherwise, make one up. +otherwise, make one up. The multiplicity argument is chosen as the multiplicity +of the variable if it is made up. -} -selectSimpleMatchVarL :: LPat GhcTc -> DsM Id +selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name -selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) +selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat) -- (selectMatchVars ps tys) chooses variables of type tys -- to use for matching ps against. If the pattern is a variable, @@ -123,20 +125,25 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) -- Then we must not choose (x::Int) as the matching variable! -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat -selectMatchVars :: [Pat GhcTc] -> DsM [Id] +selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id] -- Postcondition: the returned Ids have Internal Names -selectMatchVars ps = mapM selectMatchVar ps +selectMatchVars ps = mapM (uncurry selectMatchVar) ps -selectMatchVar :: Pat GhcTc -> DsM Id +selectMatchVar :: Mult -> Pat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name -selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) +selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar w (ParPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -selectMatchVar (AsPat _ var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) - -- OK, better make up one... + -- + -- Remark: when the pattern is a variable (or + -- an @-pattern), then w is the same as the + -- multiplicity stored within the variable + -- itself. It's easier to pull it from the + -- variable, so we ignore the multiplicity. +selectMatchVar _w (AsPat _ var _) = return (unLoc var) +selectMatchVar w other_pat = newSysLocalDsNoLP w (hsPatType other_pat) {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -348,7 +355,7 @@ mkDataConCase var ty alts@(alt1 :| _) -- (not that splitTyConApp does, these days) mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr - mk_case def alts = mkWildCase (Var var) (idType var) ty $ + mk_case def alts = mkWildCase (Var var) (idScaledType var) ty $ maybeToList def ++ alts mk_alts :: MatchResult [CoreAlt] @@ -364,7 +371,11 @@ mkDataConCase var ty alts@(alt1 :| _) Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args) - return (DataAlt con, rep_ids, mkLets binds body) + let rep_ids' = map (scaleIdBy (idMult var)) rep_ids + -- Upholds the invariant that the binders of a case expression + -- must be scaled by the case multiplicity. See Note [Case + -- expression invariants] in CoreSyn. + return (DataAlt con, rep_ids', mkLets binds body) mk_default :: MatchResult (Maybe CoreAlt) mk_default @@ -481,7 +492,8 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg case_bndr = case arg1 of Var v1 | isInternalName (idName v1) -> v1 -- Note [Desugaring seq], points (2) and (3) - _ -> mkWildValBinder ty1 + _ -> mkWildValBinder Many ty1 + mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make -- NB: No argument can be levity polymorphic @@ -654,7 +666,8 @@ work out well: ; y = case v of K x y -> y } which is better. -} - +-- Remark: pattern selectors only occur in unrestricted patterns so we are free +-- to select Many as the multiplicity of every let-expression introduced. mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -> LPat GhcTc -- ^ The pattern -> CoreExpr -- ^ Expression to which the pattern is bound @@ -669,7 +682,7 @@ mkSelectorBinds ticks pat val_expr | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDsNoLP pat_ty + ; val_var <- newSysLocalDsNoLP Many pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } @@ -687,7 +700,7 @@ mkSelectorBinds ticks pat val_expr ; return ( val_var, (val_var, val_expr) : binds) } | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs tuple_ty + = do { tuple_var <- newSysLocalDs Many tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr @@ -841,8 +854,8 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty) - ; fail_fun_arg <- newSysLocalDs voidPrimTy + = do { fail_fun_var <- newFailLocalDs Many (voidPrimTy `mkVisFunTyMany` ty) + ; fail_fun_arg <- newSysLocalDs Many voidPrimTy ; let real_arg = setOneShotLambda fail_fun_arg ; return (NonRec fail_fun_var (Lam real_arg expr), App (Var fail_fun_var) (Var voidPrimId)) } @@ -899,7 +912,9 @@ mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do uq <- newUnique this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq boolTy + let bndr1 = mkSysLocal (fsLit "t1") uq One boolTy + -- It's always sufficient to pattern-match on a boolean with + -- multiplicity 'One'. let falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index 088bce8d77..09679d0542 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -251,7 +251,7 @@ lookupIfaceTyVar (occ, _) ; return (lookupFsEnv (if_tv_env lcl) occ) } lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) -lookupIfaceVar (IfaceIdBndr (occ, _)) +lookupIfaceVar (IfaceIdBndr (_, occ, _)) = do { lcl <- getLclEnv ; return (lookupFsEnv (if_id_env lcl) occ) } lookupIfaceVar (IfaceTvBndr (occ, _)) diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 24a3aa7c5b..968acbb3c2 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -31,15 +31,17 @@ import GHC.Types.Basic import GHC.Data.BooleanFormula import GHC.Core.Class ( FunDep, className, classSCSelIds ) import GHC.Core.Utils ( exprType ) -import GHC.Core.ConLike ( conLikeName ) +import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.FVs +import GHC.Core.DataCon ( dataConNonlinearType ) import GHC.HsToCore ( deSugarExpr ) import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types import GHC.Unit.Module ( ModuleName, ml_hs_file ) import GHC.Utils.Monad ( concatMapM, liftIO ) +import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc @@ -606,11 +608,14 @@ instance ToHie (Context (Located Var)) where let name = case lookupNameEnv m (varName name') of Just var -> var Nothing-> name' + ty = case isDataConId_maybe name' of + Nothing -> varType name' + Just dc -> dataConNonlinearType dc pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ M.singleton (Right $ varName name) - (IdentifierDetails (Just $ varType name') + (IdentifierDetails (Just ty) (S.singleton context))) span []] @@ -646,7 +651,7 @@ evVarsOfTermList (EvTypeable _ ev) = case ev of EvTypeableTyCon _ e -> concatMap evVarsOfTermList e EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] - EvTypeableTrFun e1 e2 -> concatMap evVarsOfTermList [e1,e2] + EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] EvTypeableTyLit e -> evVarsOfTermList e evVarsOfTermList (EvFun{}) = [] @@ -718,6 +723,8 @@ instance HiePass p => HasType (LHsExpr (GhcPass p)) where HsLit _ l -> Just (hsLitType l) HsOverLit _ o -> Just (overLitType o) + HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con) + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) @@ -1514,6 +1521,9 @@ instance ToHie (Located (DerivStrategy GhcRn)) where instance ToHie (Located OverlapMode) where toHie (L span _) = locOnly span +instance ToHie a => ToHie (HsScaled GhcRn a) where + toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] + instance ToHie (LConDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars @@ -1543,9 +1553,11 @@ instance ToHie (LConDecl GhcRn) where rhsScope = combineScopes ctxScope argsScope ctxScope = maybe NoScope mkLScope ctx argsScope = condecl_scope dets - where condecl_scope args = case args of - PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs - InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) + where condecl_scope :: HsConDeclDetails p -> Scope + condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs + InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) + (mkLScope (hsScaledThing b)) RecCon x -> mkLScope x instance ToHie (Located [LConDeclField GhcRn]) where @@ -1657,8 +1669,9 @@ instance ToHie (TScoped (LHsType GhcRn)) where [ toHie ty , toHie $ TS (ResolvedScopes []) ki ] - HsFunTy _ a b -> - [ toHie a + HsFunTy _ w a b -> + [ toHie (arrowToHsType w) + , toHie a , toHie b ] HsListTy _ a -> diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index 3419e441a7..ce6b564b13 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -141,7 +141,7 @@ data HieType a | HAppTy a (HieArgs a) | HTyConApp IfaceTyCon (HieArgs a) | HForAllTy ((Name, a),ArgFlag) a - | HFunTy a a + | HFunTy a a a | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') | HLitTy IfaceTyLit | HCastTy a @@ -169,8 +169,9 @@ instance Binary (HieType TypeIndex) where putByte bh 3 put_ bh bndr put_ bh a - put_ bh (HFunTy a b) = do + put_ bh (HFunTy w a b) = do putByte bh 4 + put_ bh w put_ bh a put_ bh b put_ bh (HQualTy a b) = do @@ -192,7 +193,7 @@ instance Binary (HieType TypeIndex) where 1 -> HAppTy <$> get bh <*> get bh 2 -> HTyConApp <$> get bh <*> get bh 3 -> HForAllTy <$> get bh <*> get bh - 4 -> HFunTy <$> get bh <*> get bh + 4 -> HFunTy <$> get bh <*> get bh <*> get bh 5 -> HQualTy <$> get bh <*> get bh 6 -> HLitTy <$> get bh 7 -> HCastTy <$> get bh diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index b0a6f84404..102f6db656 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -12,6 +12,7 @@ import GHC.Core.Map import GHC.Driver.Session ( DynFlags ) import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type +import GHC.Core.Multiplicity import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Utils.Outputable hiding ( (<>) ) @@ -156,8 +157,8 @@ hieTypeToIface = foldType go go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t - go (HFunTy a b) = IfaceFunTy VisArg a b - go (HQualTy pred b) = IfaceFunTy InvisArg pred b + go (HFunTy w a b) = IfaceFunTy VisArg w a b + go (HQualTy pred b) = IfaceFunTy InvisArg many_ty pred b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) @@ -233,12 +234,13 @@ getTypeIndex t k <- getTypeIndex (varType v) i <- getTypeIndex t return $ HForAllTy ((varName v,k),a) i - go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do + go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do ai <- getTypeIndex a bi <- getTypeIndex b + wi <- getTypeIndex w return $ case af of - InvisArg -> HQualTy ai bi - VisArg -> HFunTy ai bi + InvisArg -> case w of Many -> HQualTy ai bi; _ -> error "Unexpected non-unrestricted predicate" + VisArg -> HFunTy wi ai bi go (LitTy a) = return $ HLitTy $ toIfaceTyLit a go (CastTy t _) = do i <- getTypeIndex t diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 37ad1db8fe..53560ca732 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -54,7 +54,6 @@ import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc ) import GHC.Types.Id.Make ( seqId ) -import GHC.Builtin.Types.Prim ( funTyConName ) import GHC.Core.Rules import GHC.Core.TyCon import GHC.Types.Annotations @@ -1060,7 +1059,6 @@ ghcPrimIface -- The fixities listed here for @`seq`@ or @->@ should match -- those in primops.txt.pp (from which Haddock docs are generated). fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) - : (occName funTyConName, funTyFixity) -- trac #10145 : mapMaybe mkFixity allThePrimOps mkFixity op = (,) (primOpOcc op) <$> primOpFixity op diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index b93d46e2d0..53385600ae 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -38,6 +38,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.StgToCmm.Types (CgInfos (..)) import GHC.Tc.Utils.TcType import GHC.Core.InstEnv @@ -223,7 +224,7 @@ mkIface_ hsc_env = do let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) entities = typeEnvElts type_env - decls = [ tyThingToIfaceDecl entity + decls = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity | entity <- entities, let name = getName entity, not (isImplicitTyThing entity), @@ -384,12 +385,12 @@ Names too: see Note [Binders in Template Haskell] in "GHC.ThToHs", and ************************************************************************ -} -tyThingToIfaceDecl :: TyThing -> IfaceDecl -tyThingToIfaceDecl (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) -tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl (AConLike cl) = case cl of - RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only +tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl +tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl dflags (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only PatSynCon ps -> patSynToIfaceDecl ps -------------------------- @@ -405,10 +406,10 @@ idToIfaceDecl id ifIdInfo = toIfaceIdInfo (idInfo id) } -------------------------- -dataConToIfaceDecl :: DataCon -> IfaceDecl -dataConToIfaceDecl dataCon +dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl +dataConToIfaceDecl dflags dataCon = IfaceId { ifName = getName dataCon, - ifType = toIfaceType (dataConUserType dataCon), + ifType = toIfaceType (dataConDisplayType dflags dataCon), ifIdDetails = IfVanillaId, ifIdInfo = [] } @@ -555,7 +556,9 @@ tyConToIfaceDecl env tycon ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, - ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, + ifConArgTys = + map (\(Scaled w t) -> (tidyToIfaceType con_env2 w + , (tidyToIfaceType con_env2 t))) arg_tys, ifConFields = dataConFieldLabels data_con, ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con), diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 0c7603c79a..50c73e56a9 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -557,7 +557,7 @@ rnIfaceConDecl d = do let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) con_ctxt <- mapM rnIfaceType (ifConCtxt d) - con_arg_tys <- mapM rnIfaceType (ifConArgTys d) + con_arg_tys <- mapM rnIfaceScaledType (ifConArgTys d) con_fields <- mapM rnFieldLabel (ifConFields d) let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co rnIfaceBang bang = pure bang @@ -644,7 +644,7 @@ rnIfaceBndrs :: Rename [IfaceBndr] rnIfaceBndrs = mapM rnIfaceBndr rnIfaceBndr :: Rename IfaceBndr -rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty) +rnIfaceBndr (IfaceIdBndr (w, fs, ty)) = IfaceIdBndr <$> ((,,) w fs <$> rnIfaceType ty) rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr rnIfaceTvBndr :: Rename IfaceTvBndr @@ -676,8 +676,8 @@ rnIfaceCo :: Rename IfaceCoercion rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty rnIfaceCo (IfaceGReflCo role ty mco) = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco -rnIfaceCo (IfaceFunCo role co1 co2) - = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceFunCo role w co1 co2) + = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2 rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos rnIfaceCo (IfaceAppCo co1 co2) @@ -722,8 +722,8 @@ rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) rnIfaceType (IfaceAppTy t1 t2) = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) -rnIfaceType (IfaceFunTy af t1 t2) - = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceFunTy af w t1 t2) + = IfaceFunTy af <$> rnIfaceType w <*> rnIfaceType t1 <*> rnIfaceType t2 rnIfaceType (IfaceTupleTy s i tks) = IfaceTupleTy s i <$> rnIfaceAppArgs tks rnIfaceType (IfaceTyConApp tc tks) @@ -735,6 +735,9 @@ rnIfaceType (IfaceCoercionTy co) rnIfaceType (IfaceCastTy ty co) = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co +rnIfaceScaledType :: Rename (IfaceMult, IfaceType) +rnIfaceScaledType (m, t) = (,) <$> rnIfaceType m <*> rnIfaceType t + rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag) rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 84e96f0706..2b0fcd2b76 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -69,7 +69,7 @@ import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn, - seqList ) + seqList, zipWithEqual ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Utils.Lexeme (isLexSym) import GHC.Builtin.Types ( constraintKindTyConName ) @@ -259,7 +259,7 @@ data IfaceConDecl -- See Note [DataCon user type variable binders] in GHC.Core.DataCon ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types + ifConArgTys :: [(IfaceMult, IfaceType)],-- Arg types ifConFields :: [FieldLabel], -- ...ditto... (field labels) ifConStricts :: [IfaceBang], -- Empty (meaning all lazy), @@ -1026,7 +1026,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, , ppWhen insert_empty_ctxt $ parens empty <+> darrow , ex_msg , pprIfaceContextArr prov_ctxt - , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) + , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ]) where univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs @@ -1148,7 +1148,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent how_much = ss_how_much ss tys_w_strs :: [(IfaceBang, IfaceType)] - tys_w_strs = zip stricts arg_tys + tys_w_strs = zip stricts (map snd arg_tys) pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) -- If we're pretty-printing a H98-style declaration with existential @@ -1165,11 +1165,17 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent -- because we don't have a Name for the tycon, only an OccName pp_tau | null fields = case pp_args ++ [pp_gadt_res_ty] of - (t:ts) -> fsep (t : map (arrow <+>) ts) + (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d) arg_tys ts) [] -> panic "pp_con_taus" | otherwise = sep [pp_field_args, arrow <+> pp_gadt_res_ty] + -- Constructors are linear by default, but we don't want to show + -- linear arrows when -XLinearTypes is disabled + ppr_arr w = sdocOption sdocLinearTypes (\linearTypes -> if linearTypes + then ppr_fun_arrow w + else arrow) + ppr_bang IfNoBang = whenPprDebug $ char '_' ppr_bang IfStrict = char '!' ppr_bang IfUnpack = text "{-# UNPACK #-}" @@ -1600,7 +1606,8 @@ freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt , ifConStricts = bangs }) = fnList freeNamesIfBndr ex_tvs &&& freeNamesIfContext ctxt &&& - fnList freeNamesIfType arg_tys &&& + fnList freeNamesIfType (map fst arg_tys) &&& -- these are multiplicities, represented as types + fnList freeNamesIfType (map snd arg_tys) &&& mkNameSet (map flSelector flds) &&& fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints fnList freeNamesIfBang bangs @@ -1624,7 +1631,7 @@ freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t -freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy _ w s t) = freeNamesIfType s &&& freeNamesIfType t &&& freeNamesIfType w freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c @@ -1636,8 +1643,8 @@ freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t freeNamesIfCoercion (IfaceGReflCo _ t mco) = freeNamesIfType t &&& freeNamesIfMCoercion mco -freeNamesIfCoercion (IfaceFunCo _ c1 c2) - = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceFunCo _ c_mult c1 c2) + = freeNamesIfCoercion c_mult &&& freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceAppCo c1 c2) @@ -1699,7 +1706,7 @@ freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k -- kinds can have Names inside, because of promotion freeNamesIfIdBndr :: IfaceIdBndr -> NameSet -freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k +freeNamesIfIdBndr (_, _fs,k) = freeNamesIfKind k freeNamesIfIdInfo :: IfaceIdInfo -> NameSet freeNamesIfIdInfo = fnList freeNamesItem diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index efb72dc77d..5121c11681 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -217,7 +217,7 @@ globaliseAndTidyBootId :: Id -> Id -- * VanillaIdInfo (makes a conservative assumption about arity) -- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) globaliseAndTidyBootId id - = globaliseId id `setIdType` tidyTopType (idType id) + = updateIdTypeAndMult tidyTopType (globaliseId id) `setIdUnfolding` BootUnfolding {- diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 6ed05e3338..acd7b51330 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -26,6 +26,7 @@ module GHC.Iface.Type ( IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), IfaceMCoercion(..), IfaceUnivCoProv(..), + IfaceMult, IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IfaceTyLit(..), IfaceAppArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, @@ -58,13 +59,16 @@ module GHC.Iface.Type ( pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, + ppr_fun_arrow, isIfaceTauType, suppressIfaceInvisibles, stripIfaceInvisVars, stripInvisArgs, - mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst + mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, + + many_ty ) where #include "HsVersions.h" @@ -73,8 +77,9 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( coercibleTyCon, heqTyCon - , liftedRepDataConTyCon, tupleTyConName ) -import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy ) + , liftedRepDataConTyCon, tupleTyConName + , manyDataConTyCon, oneDataConTyCon ) +import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom @@ -85,7 +90,6 @@ import GHC.Types.Basic import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString -import GHC.Data.FastString.Env import GHC.Utils.Misc import Data.Maybe( isJust ) @@ -109,21 +113,21 @@ data IfaceBndr -- Local (non-top-level) binders = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr -type IfaceIdBndr = (IfLclName, IfaceType) +type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) type IfaceTvBndr = (IfLclName, IfaceKind) ifaceTvBndrName :: IfaceTvBndr -> IfLclName ifaceTvBndrName (n,_) = n ifaceIdBndrName :: IfaceIdBndr -> IfLclName -ifaceIdBndrName (n,_) = n +ifaceIdBndrName (_,n,_) = n ifaceBndrName :: IfaceBndr -> IfLclName ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr ifaceBndrType :: IfaceBndr -> IfaceType -ifaceBndrType (IfaceIdBndr (_, t)) = t +ifaceBndrType (IfaceIdBndr (_, _, t)) = t ifaceBndrType (IfaceTvBndr (_, t)) = t type IfaceLamBndr = (IfaceBndr, IfaceOneShot) @@ -159,7 +163,7 @@ data IfaceType -- See Note [Suppressing invisible arguments] for -- an explanation of why the second field isn't -- IfaceType, analogous to AppTy. - | IfaceFunTy AnonArgFlag IfaceType IfaceType + | IfaceFunTy AnonArgFlag IfaceMult IfaceType IfaceType | IfaceForAllTy IfaceForAllBndr IfaceType | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated -- Includes newtypes, synonyms, tuples @@ -172,6 +176,8 @@ data IfaceType IfaceAppArgs -- arity = length args -- For promoted data cons, the kind args are omitted +type IfaceMult = IfaceType + type IfacePredType = IfaceType type IfaceContext = [IfacePredType] @@ -194,7 +200,7 @@ mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind - mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af (ifaceBndrType tv) k + mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af many_ty (ifaceBndrType tv) k mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr] @@ -354,7 +360,7 @@ data IfaceMCoercion data IfaceCoercion = IfaceReflCo IfaceType | IfaceGReflCo Role IfaceType (IfaceMCoercion) - | IfaceFunCo Role IfaceCoercion IfaceCoercion + | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceAppCo IfaceCoercion IfaceCoercion | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion @@ -438,7 +444,7 @@ splitIfaceSigmaTy ty = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } split_foralls rho = ([], rho) - split_rho (IfaceFunTy InvisArg ty1 ty2) + split_rho (IfaceFunTy InvisArg _ ty1 ty2) = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) @@ -481,7 +487,7 @@ ifTypeIsVarFree ty = go ty go (IfaceTyVar {}) = False go (IfaceFreeTyVar {}) = False go (IfaceAppTy fun args) = go fun && go_args args - go (IfaceFunTy _ arg res) = go arg && go res + go (IfaceFunTy _ w arg res) = go w && go arg && go res go (IfaceForAllTy {}) = False go (IfaceTyConApp _ args) = go_args args go (IfaceTupleTy _ _ args) = go_args args @@ -516,7 +522,7 @@ substIfaceType env ty go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv go (IfaceTyVar tv) = substIfaceTyVar env tv go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) - go (IfaceFunTy af t1 t2) = IfaceFunTy af (go t1) (go t2) + go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2) go ty@(IfaceLitTy {}) = ty go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) @@ -529,7 +535,7 @@ substIfaceType env ty go_co (IfaceReflCo ty) = IfaceReflCo (go ty) go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) - go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) + go_co (IfaceFunCo r w c1 c2) = IfaceFunCo r (go_co w) (go_co c1) (go_co c2) go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) @@ -729,7 +735,7 @@ pprIfacePrefixApp ctxt_prec pp_fun pp_tys isIfaceTauType :: IfaceType -> Bool isIfaceTauType (IfaceForAllTy _ _) = False -isIfaceTauType (IfaceFunTy InvisArg _ _) = False +isIfaceTauType (IfaceFunTy InvisArg _ _ _) = False isIfaceTauType _ = True -- ----------------------------- Printing binders ------------------------------------ @@ -747,7 +753,7 @@ pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" pprIfaceIdBndr :: IfaceIdBndr -> SDoc -pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) +pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr w) <+> dcolon <+> ppr ty) {- Note [Suppressing binder signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -844,17 +850,26 @@ pprIfaceType = pprPrecIfaceType topPrec pprParendIfaceType = pprPrecIfaceType appPrec pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc --- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe +-- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be -- called from other places, besides `:type` and `:info`. -pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty +pprPrecIfaceType prec ty = + hideNonStandardTypes (ppr_ty prec) ty + +ppr_fun_arrow :: IfaceMult -> SDoc +ppr_fun_arrow w + | (IfaceTyConApp tc _) <- w + , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow + | (IfaceTyConApp tc _) <- w + , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop + | otherwise = mulArrow (pprIfaceType w) ppr_sigma :: PprPrec -> IfaceType -> SDoc ppr_sigma ctxt_prec ty = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) ppr_ty :: PprPrec -> IfaceType -> SDoc -ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty -ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _) = ppr_sigma ctxt_prec ty +ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty +ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] @@ -862,15 +877,15 @@ ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n -- Function types -ppr_ty ctxt_prec (IfaceFunTy _ ty1 ty2) -- Should be VisArg +ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2) -- Should be VisArg = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. maybeParen ctxt_prec funPrec $ - sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)] + sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] where - ppr_fun_tail (IfaceFunTy VisArg ty1 ty2) - = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2 - ppr_fun_tail other_ty - = [arrow <+> pprIfaceType other_ty] + ppr_fun_tail wthis (IfaceFunTy VisArg wnext ty1 ty2) + = (ppr_fun_arrow wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 + ppr_fun_tail wthis other_ty + = [ppr_fun_arrow wthis <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy t ts) = if_print_coercions @@ -928,9 +943,12 @@ syntactic overhead. For this reason it was decided that we would hide RuntimeRep variables for now (see #11549). We do this by defaulting all type variables of -kind RuntimeRep to LiftedRep. This is done in a pass right before -pretty-printing (defaultRuntimeRepVars, controlled by --fprint-explicit-runtime-reps) +kind RuntimeRep to LiftedRep. +Likewise, we default all Multiplicity variables to Many. + +This is done in a pass right before pretty-printing +(defaultNonStandardVars, controlled by +-fprint-explicit-runtime-reps and -XLinearTypes) This applies to /quantified/ variables like 'w' above. What about variables that are /free/ in the type being printed, which certainly @@ -948,33 +966,36 @@ Conclusion: keep track of whether we we are in the kind of a binder; only if so, convert free RuntimeRep variables to LiftedRep. -} --- | Default 'RuntimeRep' variables to 'LiftedRep'. e.g. +-- | Default 'RuntimeRep' variables to 'LiftedRep', and 'Multiplicity' +-- variables to 'Many'. For example: -- -- @ -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). -- (a -> b) -> a -> b +-- Just :: forall (k :: Multiplicity) a. a # k -> Maybe a -- @ -- -- turns in to, -- -- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- @ Just :: forall a . a -> Maybe a @ -- --- We do this to prevent RuntimeRep variables from incurring a significant --- syntactic overhead in otherwise simple type signatures (e.g. ($)). See --- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. --- -defaultRuntimeRepVars :: IfaceType -> IfaceType -defaultRuntimeRepVars ty = go False emptyFsEnv ty +-- We do this to prevent RuntimeRep and Multiplicity variables from +-- incurring a significant syntactic overhead in otherwise simple +-- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] +-- and #11549 for further discussion. +defaultNonStandardVars :: Bool -> Bool -> IfaceType -> IfaceType +defaultNonStandardVars do_runtimereps do_multiplicities ty = go False emptyFsEnv ty where go :: Bool -- True <=> Inside the kind of a binder - -> FastStringEnv () -- Set of enclosing forall-ed RuntimeRep variables - -> IfaceType -- (replace them with LiftedRep) + -> FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables + -> IfaceType -> IfaceType go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) - | isRuntimeRep var_kind - , isInvisibleArgFlag argf -- Don't default *visible* quantification + | isInvisibleArgFlag argf -- Don't default *visible* quantification -- or we get the mess in #13963 - = let subs' = extendFsEnv subs var () + , Just substituted_ty <- check_substitution var_kind + = let subs' = extendFsEnv subs var substituted_ty -- Record that we should replace it with LiftedRep, -- and recurse, discarding the forall in go ink subs' ty @@ -982,16 +1003,16 @@ defaultRuntimeRepVars ty = go False emptyFsEnv ty go ink subs (IfaceForAllTy bndr ty) = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty) - go _ subs ty@(IfaceTyVar tv) - | tv `elemFsEnv` subs - = IfaceTyConApp liftedRep IA_Nil - | otherwise - = ty + go _ subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of + Just s -> s + Nothing -> ty go in_kind _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars - | in_kind && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) - = IfaceTyConApp liftedRep IA_Nil + | in_kind && do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) + = liftedRep_ty + | do_multiplicities && GHC.Core.Type.isMultiplicityTy (tyVarKind tv) + = many_ty | otherwise = ty @@ -1001,8 +1022,8 @@ defaultRuntimeRepVars ty = go False emptyFsEnv ty go ink subs (IfaceTupleTy sort is_prom tc_args) = IfaceTupleTy sort is_prom (go_args ink subs tc_args) - go ink subs (IfaceFunTy af arg res) - = IfaceFunTy af (go ink subs arg) (go ink subs res) + go ink subs (IfaceFunTy af w arg res) + = IfaceFunTy af (go ink subs w) (go ink subs arg) (go ink subs res) go ink subs (IfaceAppTy t ts) = IfaceAppTy (go ink subs t) (go_args ink subs ts) @@ -1013,33 +1034,45 @@ defaultRuntimeRepVars ty = go False emptyFsEnv ty go _ _ ty@(IfaceLitTy {}) = ty go _ _ ty@(IfaceCoercionTy {}) = ty - go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr - go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf) - = Bndr (IfaceIdBndr (n, go True subs t)) argf + go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr + go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf) + = Bndr (IfaceIdBndr (w, n, go True subs t)) argf go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) = Bndr (IfaceTvBndr (n, go True subs t)) argf - go_args :: Bool -> FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs + go_args :: Bool -> FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs go_args _ _ IA_Nil = IA_Nil go_args ink subs (IA_Arg ty argf args) = IA_Arg (go ink subs ty) argf (go_args ink subs args) - liftedRep :: IfaceTyCon - liftedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) - where dc_name = getName liftedRepDataConTyCon - - isRuntimeRep :: IfaceType -> Bool - isRuntimeRep (IfaceTyConApp tc _) = - tc `ifaceTyConHasKey` runtimeRepTyConKey - isRuntimeRep _ = False - -eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc -eliminateRuntimeRep f ty + check_substitution :: IfaceType -> Maybe IfaceType + check_substitution (IfaceTyConApp tc _) + | do_runtimereps, tc `ifaceTyConHasKey` runtimeRepTyConKey = Just liftedRep_ty + | do_multiplicities, tc `ifaceTyConHasKey` multiplicityTyConKey = Just many_ty + check_substitution _ = Nothing + +liftedRep_ty :: IfaceType +liftedRep_ty = + IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName liftedRepDataConTyCon + +many_ty :: IfaceType +many_ty = + IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName manyDataConTyCon + +hideNonStandardTypes :: (IfaceType -> SDoc) -> IfaceType -> SDoc +hideNonStandardTypes f ty = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps -> + sdocOption sdocLinearTypes $ \linearTypes -> getPprStyle $ \sty -> - if userStyle sty && not printExplicitRuntimeReps - then f (defaultRuntimeRepVars ty) - else f ty + let do_runtimerep = not printExplicitRuntimeReps + do_multiplicity = not linearTypes + in if userStyle sty + then f (defaultNonStandardVars do_runtimerep do_multiplicity ty) + else f ty instance Outputable IfaceAppArgs where ppr tca = pprIfaceAppArgs tca @@ -1148,7 +1181,7 @@ data ShowForAllFlag = ShowForAllMust | ShowForAllWhen pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty - = eliminateRuntimeRep ppr_fn ty + = hideNonStandardTypes ppr_fn ty where ppr_fn iface_ty = let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty @@ -1339,6 +1372,11 @@ pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug , rep `ifaceTyConHasKey` liftedRepDataConKey = ppr_kind_type ctxt_prec + | tc `ifaceTyConHasKey` funTyConKey + , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys + , rep `ifaceTyConHasKey` manyDataConKey + = pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) (appArgsIfaceTypes $ stripInvisArgs printExplicitKinds args)) + | otherwise = getPprDebug $ \dbg -> if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey @@ -1550,14 +1588,15 @@ ppr_co _ (IfaceGReflCo r ty IfaceMRefl) ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) = ppr_special_co ctxt_prec (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] -ppr_co ctxt_prec (IfaceFunCo r co1 co2) +ppr_co ctxt_prec (IfaceFunCo r cow co1 co2) = maybeParen ctxt_prec funPrec $ - sep (ppr_co funPrec co1 : ppr_fun_tail co2) + sep (ppr_co funPrec co1 : ppr_fun_tail cow co2) where - ppr_fun_tail (IfaceFunCo r co1 co2) - = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2 - ppr_fun_tail other_co - = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] + ppr_fun_tail cow' (IfaceFunCo r cow co1 co2) + = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2 + ppr_fun_tail cow' other_co + = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co] + coercionArrow w = mulArrow (ppr_co topPrec w) ppr_co _ (IfaceTyConAppCo r tc cos) = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r @@ -1572,7 +1611,7 @@ ppr_co ctxt_prec co@(IfaceForAllCo {}) split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co') + split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co') = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') split_co co' = ([], co') @@ -1777,9 +1816,10 @@ instance Binary IfaceType where putByte bh 2 put_ bh ae put_ bh af - put_ bh (IfaceFunTy af ag ah) = do + put_ bh (IfaceFunTy af aw ag ah) = do putByte bh 3 put_ bh af + put_ bh aw put_ bh ag put_ bh ah put_ bh (IfaceTyConApp tc tys) @@ -1805,9 +1845,10 @@ instance Binary IfaceType where af <- get bh return (IfaceAppTy ae af) 3 -> do af <- get bh + aw <- get bh ag <- get bh ah <- get bh - return (IfaceFunTy af ag ah) + return (IfaceFunTy af aw ag ah) 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } 6 -> do { a <- get bh; b <- get bh @@ -1844,9 +1885,10 @@ instance Binary IfaceCoercion where put_ bh a put_ bh b put_ bh c - put_ bh (IfaceFunCo a b c) = do + put_ bh (IfaceFunCo a w b c) = do putByte bh 3 put_ bh a + put_ bh w put_ bh b put_ bh c put_ bh (IfaceTyConAppCo a b c) = do @@ -1922,9 +1964,10 @@ instance Binary IfaceCoercion where c <- get bh return $ IfaceGReflCo a b c 3 -> do a <- get bh + w <- get bh b <- get bh c <- get bh - return $ IfaceFunCo a b c + return $ IfaceFunCo a w b c 4 -> do a <- get bh b <- get bh c <- get bh @@ -2008,7 +2051,7 @@ instance NFData IfaceType where IfaceTyVar f1 -> rnf f1 IfaceLitTy f1 -> rnf f1 IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 - IfaceFunTy f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunTy f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 @@ -2024,7 +2067,7 @@ instance NFData IfaceCoercion where rnf = \case IfaceReflCo f1 -> rnf f1 IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 - IfaceFunCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 7767f50e2e..1b0eb0d604 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -78,6 +78,7 @@ import GHC.Data.FastString import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Data.List.SetOps import GHC.Fingerprint +import GHC.Core.Multiplicity import qualified GHC.Data.BooleanFormula as BF import Control.Monad @@ -924,7 +925,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons -- below is always guaranteed to succeed. ; user_tv_bndrs <- mapM (\(Bndr bd vis) -> case bd of - IfaceIdBndr (name, _) -> + IfaceIdBndr (_, name, _) -> Bndr <$> tcIfaceLclId name <*> pure vis IfaceTvBndr (name, _) -> Bndr <$> tcIfaceTyVar name <*> pure vis) @@ -945,7 +946,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons -- the argument types was recursively defined. -- See also Note [Tying the knot] ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys") - $ mapM tcIfaceType args + $ mapM (\(w, ty) -> mkScaled <$> tcIfaceType w <*> tcIfaceType ty) args ; stricts <- mapM tc_strict if_stricts -- The IfBang field can mention -- the type itself; hence inside forkM @@ -1164,11 +1165,11 @@ tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t) tcIfaceType :: IfaceType -> IfL Type tcIfaceType = go where - go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n - go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) - go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l - go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2 - go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks + go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n + go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) + go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l + go (IfaceFunTy flag w t1 t2) = FunTy flag <$> tcIfaceType w <*> go t1 <*> go t2 + go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks go (IfaceAppTy t ts) = do { t' <- go t ; ts' <- traverse go (appArgsIfaceTypes ts) @@ -1240,7 +1241,7 @@ tcIfaceCo = go go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco - go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 + go (IfaceFunCo r w c1 c2) = mkFunCo r <$> go w <*> go c1 <*> go c2 go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 @@ -1342,7 +1343,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' - case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty + case_mult = Many + case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. tc_app = splitTyConApp scrut_ty @@ -1353,7 +1355,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do -- corresponds to the datacon in this case alternative extendIfaceIdEnv [case_bndr'] $ do - alts' <- mapM (tcIfaceAlt scrut' tc_app) alts + alts' <- mapM (tcIfaceAlt scrut' case_mult tc_app) alts return (Case scrut' case_bndr' (coreAltsType alts') alts') tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) @@ -1361,7 +1363,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} NotTopLevel name ty' info - ; let id = mkLocalIdWithInfo name ty' id_info + ; let id = mkLocalIdWithInfo name Many ty' id_info `asJoinId_maybe` tcJoinInfo ji ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) @@ -1377,7 +1379,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) tc_rec_bndr (IfLetBndr fs ty _ ji) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) } + ; return (mkLocalId name Many ty' `asJoinId_maybe` tcJoinInfo ji) } tc_pair (IfLetBndr _ _ info _, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} @@ -1418,15 +1420,15 @@ tcIfaceLit (LitNumber LitNumNatural i _) tcIfaceLit lit = return lit ------------------------- -tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) +tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type]) -> (IfaceConAlt, [FastString], IfaceExpr) -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceAlt _ _ (IfaceDefault, names, rhs) +tcIfaceAlt _ _ _ (IfaceDefault, names, rhs) = ASSERT( null names ) do rhs' <- tcIfaceExpr rhs return (DEFAULT, [], rhs') -tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) +tcIfaceAlt _ _ _ (IfaceLitAlt lit, names, rhs) = ASSERT( null names ) do lit' <- tcIfaceLit lit rhs' <- tcIfaceExpr rhs @@ -1435,19 +1437,19 @@ tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) +tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { con <- tcIfaceDataCon data_occ ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) - ; tcIfaceDataAlt con inst_tys arg_strs rhs } + ; tcIfaceDataAlt mult con inst_tys arg_strs rhs } -tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr +tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr -> IfL (AltCon, [TyVar], CoreExpr) -tcIfaceDataAlt con inst_tys arg_strs rhs +tcIfaceDataAlt mult con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us ; let (ex_tvs, arg_ids) - = dataConRepFSInstPat arg_strs uniqs con inst_tys + = dataConRepFSInstPat arg_strs uniqs mult con inst_tys ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $ @@ -1804,10 +1806,11 @@ tcIfaceImplicit n = do -} bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceId (fs, ty) thing_inside +bindIfaceId (w, fs, ty) thing_inside = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; let id = mkLocalIdOrCoVar name ty' + ; w' <- tcIfaceType w + ; let id = mkLocalIdOrCoVar name w' ty' -- We should not have "OrCoVar" here, this is a bug (#17545) ; extendIfaceIdEnv [id] (thing_inside id) } diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 07e7572092..3fddd993fe 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -74,7 +74,7 @@ import GHC.Unit.Module import GHC.Types.Basic import GHC.Types.ForeignCall -import GHC.Core.Type ( funTyCon, Specificity(..) ) +import GHC.Core.Type ( unrestrictedFunTyCon, Mult(..), Specificity(..) ) import GHC.Core.Class ( FunDep ) -- compiler/parser @@ -89,7 +89,8 @@ import GHC.Tc.Types.Evidence ( emptyTcEvBinds ) import GHC.Builtin.Types.Prim ( eqPrimTyCon ) import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) + listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR, + manyDataConTyCon) } %expect 232 -- shift/reduce conflicts @@ -540,6 +541,7 @@ are the most common patterns, rewritten as regular expressions for clarity: '|' { L _ ITvbar } '<-' { L _ (ITlarrow _) } '->' { L _ (ITrarrow _) } + '#->' { L _ (ITlolly _) } TIGHT_INFIX_AT { L _ ITat } '=>' { L _ (ITdarrow _) } '-' { L _ ITminus } @@ -642,9 +644,9 @@ identifier :: { Located RdrName } | qcon { $1 } | qvarop { $1 } | qconop { $1 } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) [mop $1,mu AnnRarrow $2,mcp $3] } - | '->' {% ams (sLL $1 $> $ getRdrName funTyCon) + | '->' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) [mu AnnRarrow $1] } ----------------------------------------------------------------------------- @@ -2000,27 +2002,41 @@ is connected to the first type too. type :: { LHsType GhcPs } : btype { $1 } | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField $1 $3) + >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3) [mu AnnRarrow $2] } + | btype '#->' ctype {% hintLinear (getLoc $2) >> + ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3) + [mu AnnRarrow $2] } + +mult :: { LHsType GhcPs } + : btype { $1 } + typedoc :: { LHsType GhcPs } : btype { $1 } | btype docprev { sLL $1 $> $ HsDocTy noExtField $1 $2 } | docnext btype { sLL $1 $> $ HsDocTy noExtField $2 $1 } | btype '->' ctypedoc {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField $1 $3) + >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3) [mu AnnRarrow $2] } | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExtField (L (comb2 $1 $2) - (HsDocTy noExtField $1 $2)) - $4) + HsFunTy noExtField HsUnrestrictedArrow + (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4) + [mu AnnRarrow $3] } + | btype '#->' ctypedoc {% hintLinear (getLoc $2) >> + ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3) + [mu AnnRarrow $2] } + | btype docprev '#->' ctypedoc {% hintLinear (getLoc $2) >> + ams (sLL $1 $> $ + HsFunTy noExtField HsLinearArrow + (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4) [mu AnnRarrow $3] } | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExtField (L (comb2 $1 $2) - (HsDocTy noExtField $2 $1)) + HsFunTy noExtField HsUnrestrictedArrow + (L (comb2 $1 $2) (HsDocTy noExtField $2 $1)) $4) [mu AnnRarrow $3] } @@ -3484,7 +3500,7 @@ ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed (snd $2 + 1))) (mo $1:mc $3:(mcommas (fst $2))) } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) [mop $1,mu AnnRarrow $2,mcp $3] } | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } @@ -3568,7 +3584,7 @@ tyconsym :: { Located RdrName } op :: { Located RdrName } -- used in infix decls : varop { $1 } | conop { $1 } - | '->' { sL1 $1 $ getRdrName funTyCon } + | '->' { sL1 $1 $ getRdrName unrestrictedFunTyCon } varop :: { Located RdrName } : varsym { $1 } @@ -3985,6 +4001,13 @@ fileSrcSpan = do let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) +-- Hint about linear types +hintLinear :: SrcSpan -> P () +hintLinear span = do + linearEnabled <- getBit LinearTypesBit + unless linearEnabled $ addError span $ + text "Enable LinearTypes to allow linear functions" + -- Hint about the MultiWayIf extension hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 6778d5aa3f..2df6400a19 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -762,6 +762,7 @@ data Token | ITvbar | ITlarrow IsUnicodeSyntax | ITrarrow IsUnicodeSyntax + | ITlolly IsUnicodeSyntax | ITdarrow IsUnicodeSyntax | ITminus | ITbang -- Prefix (!) only, e.g. f !x = rhs @@ -984,6 +985,9 @@ reservedSymsFM = listToUFM $ ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("#->", ITlolly NormalSyntax, NormalSyntax, 0) + ,("⊸", ITlolly UnicodeSyntax, UnicodeSyntax, 0) + ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) @@ -2475,6 +2479,7 @@ data ExtBits | MultiWayIfBit | GadtSyntaxBit | ImportQualifiedPostBit + | LinearTypesBit -- Flags that are updated once parsing starts | InRulePragBit @@ -2561,6 +2566,7 @@ mkParserFlags' warningFlags extensionFlags homeUnitId .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost + .|. LinearTypesBit `xoptBit` LangExt.LinearTypes optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 645f56fc54..018ce7bb60 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -115,7 +115,7 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Parser.Lexer import GHC.Utils.Lexeme ( isLexCon ) -import GHC.Core.Type ( TyThing(..), funTyCon, Specificity(..) ) +import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, @@ -710,7 +710,7 @@ mkGadtDecl names ty where mb_record_gadt ty | (mtvs, mcxt, body_ty) <- splitLHsGADTPrefixTy ty - , L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty) <- body_ty + , L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty = Just (mtvs, mcxt, RecCon (L loc rf), res_ty) | otherwise = Nothing @@ -1650,7 +1650,7 @@ mergeDataCon all_xs = goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () , ( L l (getRdrName (tupleDataCon Boxed (length ts))) - , PrefixCon ts + , PrefixCon (map hsLinear ts) , mTrailingDoc ) ) goFirst ((L l (TyElOpd t)):xs) | (_, t', addAnns, xs') <- pBangTy (L l t) xs @@ -1662,7 +1662,7 @@ mergeDataCon all_xs = go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc - ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } + ; return (addAnns, (data_con, PrefixCon (map hsLinear ts), mkConDoc mLastDoc)) } go addAnns mLastDoc ts ((L l (TyElDocPrev doc)):xs) = go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs go addAnns mLastDoc ts ((L l (TyElOpd t)):xs) @@ -1697,7 +1697,7 @@ mergeDataCon all_xs = ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc lhs = mkLHsDocTyMaybe lhs_t mLhsDoc addAnns = lhs_addAnns >> rhs_addAnns - ; return (addAnns, (op, InfixCon lhs rhs, mkConDoc mOpDoc)) } + ; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs), mkConDoc mOpDoc)) } where malformedErr = ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') @@ -2565,8 +2565,9 @@ checkPrecP (L l (_,i)) (L _ ol) | all specialOp ol = pure () | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) where + -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs specialOp op = unLoc op `elem` [ eqTyCon_RDR - , getRdrName funTyCon ] + , getRdrName unrestrictedFunTyCon ] mkRecConstrOrUpdate :: LHsExpr GhcPs diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 3f3eb48b68..0def086cb5 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -18,6 +18,8 @@ module GHC.Rename.HsType ( rnConDeclFields, rnLTyVar, + rnScaledLHsType, + -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, @@ -512,6 +514,14 @@ rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys +rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs) + -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars) +rnScaledLHsType doc (HsScaled w ty) = do + (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w + (ty', fvs) <- rnLHsType doc ty + return (HsScaled w' ty', fvs `plusFV` fvs_w) + + rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty @@ -617,7 +627,7 @@ rnHsTyKi env ty@(HsRecTy _ flds) 2 (ppr ty)) ; return [] } -rnHsTyKi env (HsFunTy _ ty1 ty2) +rnHsTyKi env (HsFunTy _ mult ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 -- Might find a for-all as the arg of a function type ; (ty2', fvs2) <- rnLHsTyKi env ty2 @@ -625,8 +635,11 @@ rnHsTyKi env (HsFunTy _ ty1 ty2) -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2' - ; return (res_ty, fvs1 `plusFV` fvs2) } + ; (mult', w_fvs) <- rnHsArrow env mult + ; res_ty <- mkHsOpTyRn (hs_fun_ty mult') funTyConName funTyFixity ty1' ty2' + ; return (res_ty, fvs1 `plusFV` fvs2 `plusFV` w_fvs) } + where + hs_fun_ty w a b = HsFunTy noExtField w a b rnHsTyKi env listTy@(HsListTy _ ty) = do { data_kinds <- xoptM LangExt.DataKinds @@ -722,6 +735,12 @@ rnHsTyKi env (HsWildCardTy _) = do { checkAnonWildCard env ; return (HsWildCardTy noExtField, emptyFVs) } +rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) +rnHsArrow _env HsUnrestrictedArrow = return (HsUnrestrictedArrow, emptyFVs) +rnHsArrow _env HsLinearArrow = return (HsLinearArrow, emptyFVs) +rnHsArrow env (HsExplicitMult p) + = (\(mult, fvs) -> (HsExplicitMult mult, fvs)) <$> rnLHsTyKi env p + -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name rnTyVar env rdr_name @@ -1209,9 +1228,11 @@ mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ mult ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 + hs_fun_ty funTyConName funTyFixity ty21 ty22 loc2 + where + hs_fun_ty a b = HsFunTy noExtField mult a b mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) @@ -1816,8 +1837,9 @@ extract_lty (L _ ty) acc HsListTy _ ty -> extract_lty ty acc HsTupleTy _ _ tys -> extract_ltys tys acc HsSumTy _ tys -> extract_ltys tys acc - HsFunTy _ ty1 ty2 -> extract_lty ty1 $ - extract_lty ty2 acc + HsFunTy _ w ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 $ + extract_hs_arrow w acc HsIParamTy _ _ ty -> extract_lty ty acc HsOpTy _ ty1 tv ty2 -> extract_tv tv $ extract_lty ty1 $ @@ -1841,6 +1863,11 @@ extract_lty (L _ ty) acc -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc +extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> + FreeKiTyVars +extract_hs_arrow (HsExplicitMult p) acc = extract_lty p acc +extract_hs_arrow _ acc = acc + extract_hs_for_all_telescope :: HsForAllTelescope GhcPs -> FreeKiTyVars -- Accumulator -> FreeKiTyVars -- Free in body diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index e610a60ff3..cad85e2fe5 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2133,7 +2133,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names -- See #14808. ; implicit_bndrs <- forAllOrNothing explicit_forall $ extractHsTvBndrs explicit_tkvs - $ extractHsTysRdrTyVars (theta ++ arg_tys ++ [res_ty]) + $ extractHsTysRdrTyVars (theta ++ map hsScaledThing arg_tys ++ [res_ty]) ; let ctxt = ConDeclCtx new_names @@ -2166,6 +2166,7 @@ rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty ; let ctxt = ConDeclCtx new_names ; (ty', fvs) <- rnHsSigType ctxt TypeLevel Nothing ty + ; linearTypes <- xopt LangExt.LinearTypes <$> getDynFlags -- Now that operator precedence has been resolved, we can split the -- GADT type into its individual components below. @@ -2174,7 +2175,9 @@ rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty lhas_forall = L (getLoc body) $ isJust mb_explicit_tkvs explicit_tkvs = fromMaybe [] mb_explicit_tkvs (arg_tys, res_ty) = splitHsFunType tau - arg_details = PrefixCon arg_tys + arg_details | linearTypes = PrefixCon arg_tys + | otherwise = PrefixCon $ map (hsLinear . hsScaledThing) arg_tys + -- NB: The only possibility here is PrefixCon. RecCon is handled -- separately, through ConDeclGADT, from the parser onwards. @@ -2217,16 +2220,16 @@ rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt rnConDeclDetails :: Name -> HsDocContext - -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) - -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), + -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs]) + -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]), FreeVars) rnConDeclDetails _ doc (PrefixCon tys) - = do { (new_tys, fvs) <- rnLHsTypes doc tys + = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys ; return (PrefixCon new_tys, fvs) } rnConDeclDetails _ doc (InfixCon ty1 ty2) - = do { (new_ty1, fvs1) <- rnLHsType doc ty1 - ; (new_ty2, fvs2) <- rnLHsType doc ty2 + = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1 + ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclDetails con doc (RecCon (L l fields)) diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 5f7ff50347..43aacc2085 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -75,8 +75,8 @@ pprintClosureCommand bindThings force str = do -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) go subst id = do - let id_ty' = substTy subst (idType id) - id' = id `setIdType` id_ty' + let id' = updateIdTypeAndMult (substTy subst) id + id_ty' = idType id' term_ <- GHC.obtainTermFromId maxBound force id' term <- tidyTermTyVars term_ term' <- if bindThings diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 55b4f3d32b..e33c8329d4 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -63,6 +63,7 @@ import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.TyCon +import GHC.Core.Multiplicity ( irrelevantMult ) import GHC.Core.Type hiding( typeKind ) import qualified GHC.Core.Type as Type import GHC.Types.RepType @@ -1102,7 +1103,7 @@ findMatchingInstances ty = do try_cls ies cls | Just (arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) , tcIsConstraintKind res_kind - , Type.typeKind ty `eqType` arg_kind + , Type.typeKind ty `eqType` irrelevantMult arg_kind , (matches, _, _) <- lookupInstEnv True ies cls [ty] = matches | otherwise diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 3077c48aaf..debcc68f29 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -36,6 +36,7 @@ import GHCi.Message ( fromSerializableException ) import GHC.Core.DataCon import GHC.Core.Type import GHC.Types.RepType +import GHC.Core.Multiplicity import qualified GHC.Core.Unify as U import GHC.Types.Var import GHC.Tc.Utils.Monad @@ -760,9 +761,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do traceTR (text "Following a MutVar") contents_tv <- newVar liftedTypeKind MASSERT(isUnliftedType my_ty) - (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy + (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany contents_ty (mkTyConApp tycon [world,contents_ty]) - addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty + addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents return (RefWrap my_ty x) @@ -1055,7 +1056,7 @@ getDataConArgTys dc con_app_ty ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) -- See Note [Constructor arg types] - ; let con_arg_tys = substTys subst (dataConRepArgTys dc) + ; let con_arg_tys = substTys subst (map scaledThing $ dataConRepArgTys dc) ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) ; return con_arg_tys } where @@ -1263,11 +1264,12 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') ppr tv, equals, ppr ty_v] go ty_v r -- FunTy inductive case - | Just (l1,l2) <- splitFunTy_maybe l - , Just (r1,r2) <- splitFunTy_maybe r + | Just (Scaled w1 l1,l2) <- splitFunTy_maybe l + , Just (Scaled w2 r1,r2) <- splitFunTy_maybe r + , w1 `eqType` w2 = do r2' <- go l2 r2 r1' <- go l1 r1 - return (mkVisFunTy r1' r2') + return (mkVisFunTy w1 r1' r2') -- TyconApp Inductive case; this is the interesting bit. | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs @@ -1333,7 +1335,7 @@ isMonomorphicOnNonPhantomArgs ty , tyv `notElem` phantom_vars] = all isMonomorphicOnNonPhantomArgs concrete_args | Just (ty1, ty2) <- splitFunTy_maybe ty - = all isMonomorphicOnNonPhantomArgs [ty1,ty2] + = all isMonomorphicOnNonPhantomArgs [scaledThing ty1,ty2] | otherwise = isMonomorphic ty tyConPhantomTyVars :: TyCon -> [TyVar] diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index b693730eca..21097cc59f 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -39,6 +39,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Types.Var.Env import GHC.Types.Var.Set +import GHC.Core.Multiplicity import Control.Arrow ( second ) import Control.Monad.Trans.Class @@ -274,7 +275,7 @@ withLiftedBndr abs_ids bndr inner = do -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal (mkFastString str) uniq + . mkSysLocal (mkFastString str) uniq Many $ ty LiftM $ RWS.local (\e -> e diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index da2b06809e..3e5d2f3101 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -192,7 +192,7 @@ STG programs after unarisation have these invariants: * Binders always have zero (for void arguments) or one PrimRep. -} -{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE CPP, TupleSections, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -220,6 +220,7 @@ import GHC.Builtin.Types import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Types.Var.Env +import GHC.Core.Multiplicity ( pattern Many ) import Data.Bifunctor (second) import Data.Maybe (mapMaybe) @@ -740,7 +741,7 @@ mkIds :: FastString -> [UnaryType] -> UniqSM [Id] mkIds fs tys = mapM (mkId fs) tys mkId :: FastString -> UnaryType -> UniqSM Id -mkId = mkSysLocalM +mkId s t = mkSysLocalM s Many t isMultiValBndr :: Id -> Bool isMultiValBndr id diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 43b3cfc635..1ec7abe5a0 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -43,6 +43,7 @@ import GHC.Types.Id.Info import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon +import GHC.Core.Multiplicity import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Data.Stream @@ -242,7 +243,7 @@ cgDataCon data_con arg_reps :: [NonVoid PrimRep] arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con - , rep_ty <- typePrimRep ty + , rep_ty <- typePrimRep (scaledThing ty) , not (isVoidRep rep_ty) ] ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $ diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 6a13cfaccd..a1af9166fe 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -40,6 +40,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Set @@ -557,7 +558,7 @@ deepSubtypesContaining tv foldDataConArgs :: FFoldType a -> DataCon -> [a] -- Fold over the arguments of the datacon foldDataConArgs ft con - = map foldArg (dataConOrigArgTys con) + = map foldArg (map scaledThing $ dataConOrigArgTys con) where foldArg = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index a9791043a2..7fa9975790 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -66,6 +66,7 @@ import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.Class import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -210,7 +211,7 @@ gen_Eq_binds loc tycon = do bs_needed = take con_arity bs_RDRs tys_needed = dataConOrigArgTys data_con in - ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) + ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed) where nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs @@ -456,7 +457,7 @@ gen_Ord_binds loc tycon = do -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) mkInnerEqAlt op data_con = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ - mkCompareFields op (dataConOrigArgTys data_con) + mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con) where data_con_RDR = getRdrName data_con bs_needed = take (dataConSourceArity data_con) bs_RDRs @@ -1044,7 +1045,7 @@ gen_Read_binds get_fixity loc tycon is_infix = dataConIsInfix data_con is_record = labels `lengthExceeds` 0 as_needed = take con_arity as_RDRs - read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) + read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con) (read_a1:read_a2:_) = read_args prefix_prec = appPrecedence @@ -1187,7 +1188,7 @@ gen_Show_binds get_fixity loc tycon where nm = wrapOpParens (unpackFS l) - show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys + show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys) (show_arg1:show_arg2:_) = show_args show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args @@ -1378,7 +1379,7 @@ gen_data dflags data_type_name constr_names loc rep_tc gfoldl_eqn con = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], - foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) + foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed) where con_name :: RdrName con_name = getRdrName con @@ -1398,9 +1399,18 @@ gen_data dflags data_type_name constr_names loc rep_tc gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) mk_unfold_rhs dc = foldr nlHsApp - (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) + (z_Expr `nlHsApp` (eta_expand_data_con dc)) (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + eta_expand_data_con dc = + mkHsLam eta_expand_pats + (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars) + where + eta_expand_pats = map nlVarPat eta_expand_vars + eta_expand_hsvars = map nlHsVar eta_expand_vars + eta_expand_vars = take (dataConSourceArity dc) as_RDRs + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid -- redundant test, and annoying warning | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor @@ -1448,7 +1458,7 @@ gen_data dflags data_type_name constr_names loc rep_tc kind1, kind2 :: Kind kind1 = typeToTypeKind -kind2 = liftedTypeKind `mkVisFunTy` kind1 +kind2 = liftedTypeKind `mkVisFunTyMany` kind1 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, @@ -1960,7 +1970,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon) sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ - mkParentType tycon `mkVisFunTy` intPrimTy + mkParentType tycon `mkVisFunTyMany` intPrimTy lots_of_constructors = tyConFamilySize tycon > 8 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS @@ -1984,7 +1994,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) where sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ - intTy `mkVisFunTy` mkParentType tycon + intTy `mkVisFunTyMany` mkParentType tycon rdr_name = tag2con_RDR dflags tycon diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index ced6f4b690..ea9862d305 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -29,6 +29,7 @@ import GHC.Tc.Deriv.Functor import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) +import GHC.Core.Multiplicity import GHC.Tc.Instance.Family import GHC.Unit.Module ( moduleName, moduleNameFS , moduleUnit, unitFS, getModule ) @@ -168,7 +169,7 @@ canDoGenerics tc -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) + bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)) then (NotValid (ppr dc <+> text "must not have exotic unlifted or polymorphic arguments")) else (if (not (isVanillaDataCon dc)) @@ -575,7 +576,7 @@ tc_mkRepTy gk_ tycon k = mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] mkC a = mkTyConApp c1 [ k , metaConsTy a - , prod (dataConInstOrigArgTys a + , prod (map scaledThing . dataConInstOrigArgTys a . mkTyVarTys . tyConTyVars $ tycon) (dataConSrcBangs a) (dataConImplBangs a) @@ -741,7 +742,7 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt) argTys = dataConOrigArgTys datacon n_args = dataConSourceArity datacon - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) (map scaledThing argTys) datacon_vars = map fst datacon_varTys datacon_rdr = getRdrName datacon diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index 56dafd2097..17eff9a74b 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -41,6 +41,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Ppr (pprTyVars) import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Tc.Solver import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) @@ -186,10 +187,10 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys dataConInstOrigArgTys data_con all_rep_tc_args -- No constraints for unlifted types -- See Note [Deriving and unboxed types] - , not (isUnliftedType arg_ty) + , not (isUnliftedType (irrelevantMult arg_ty)) , let orig = DerivOriginDC data_con arg_n wildcard , preds_and_mbSubst - <- get_arg_constraints orig arg_t_or_k arg_ty + <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty) ] preds = concat predss -- If the constraints require a subtype to be of kind diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 66adb4e554..e118c69830 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -48,6 +48,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon +import GHC.Core.Multiplicity import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import GHC.Utils.Misc @@ -853,7 +854,7 @@ cond_stdOK deriv_ctxt permissive dflags tc rep_tc = bad "has existential type variables in its type" | not (null theta) -- 4. = bad "has constraints in its type" - | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5. + | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5. = bad "has a higher-rank type" | otherwise = IsValid @@ -887,7 +888,7 @@ cond_args cls _ _ rep_tc 2 (text "for type" <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons rep_tc - , arg_ty <- dataConOrigArgTys con + , Scaled _ arg_ty <- dataConOrigArgTys con , isLiftedType_maybe arg_ty /= Just True , not (ok_ty arg_ty) ] diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index d38b7adcbd..631be3465f 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -2079,7 +2079,7 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) (t1_2', t2_2') = go t1_2 t2_2 in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) = + go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = let (t1_1', t2_1') = go t1_1 t2_1 (t1_2', t2_2') = go t1_2 t2_2 in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 7c0eaa7912..2edce28eac 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -620,7 +620,7 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ where newTyVars = replicateM refLvl $ setLvl <$> (newOpenTypeKind >>= newFlexiTyVar) setLvl = flip setMetaTyVarTcLevel hole_lvl - wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty + wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty sortFits :: SortingAlg -- How we should sort the hole fits -> [HoleFit] -- The subs to sort @@ -758,34 +758,34 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = do { traceTc "lookingUp" $ ppr el ; maybeThing <- lookup el ; case maybeThing of - Just id | not_trivial id -> - do { fits <- fitsHole ty (idType id) + Just (id, id_ty) | not_trivial id -> + do { fits <- fitsHole ty id_ty ; case fits of - Just (wrp, matches) -> keep_it id wrp matches + Just (wrp, matches) -> keep_it id id_ty wrp matches _ -> discard_it } _ -> discard_it } where -- We want to filter out undefined and the likes from GHC.Err not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR - lookup :: HoleFitCandidate -> TcM (Maybe Id) - lookup (IdHFCand id) = return (Just id) + lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type)) + lookup (IdHFCand id) = return (Just (id, idType id)) lookup hfc = do { thing <- tcLookup name ; return $ case thing of - ATcId {tct_id = id} -> Just id - AGlobal (AnId id) -> Just id + ATcId {tct_id = id} -> Just (id, idType id) + AGlobal (AnId id) -> Just (id, idType id) AGlobal (AConLike (RealDataCon con)) -> - Just (dataConWrapId con) + Just (dataConWrapId con, dataConNonlinearType con) _ -> Nothing } where name = case hfc of IdHFCand id -> idName id GreHFCand gre -> gre_name gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts - keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid) + keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) ((\n -> n - 1) <$> maxleft) ty elts where - fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid) + fit = HoleFit { hfId = eid, hfCand = el, hfType = eid_ty , hfRefLvl = length (snd ty) , hfWrap = wrp, hfMatches = ms , hfDoc = Nothing } diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index c21a885970..6c5fda73af 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -29,6 +29,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence +import GHC.Core.Multiplicity import GHC.Types.Id( mkLocalId ) import GHC.Tc.Utils.Instantiate import GHC.Builtin.Types @@ -92,7 +93,7 @@ tcProc pat cmd exp_ty ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcCheckPat ProcExpr pat arg_ty $ + ; (pat', cmd') <- tcCheckPat ProcExpr pat (unrestricted arg_ty) $ tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) @@ -179,7 +180,7 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn (text "Predicate type of `ifThenElse' depends on result type") ; (pred', fun') <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) - (mkCheckExpType r_ty) $ \ _ -> + (mkCheckExpType r_ty) $ \ _ _ -> tcCheckMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty @@ -254,13 +255,13 @@ tc_cmd env -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ + tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) ; let match' = L mtch_loc (Match { m_ext = noExtField , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) - arg_tys = map hsLPatType pats' + arg_tys = map (unrestricted . hsLPatType) pats' cmd' = HsCmdLam x (MG { mg_alts = L l [match'] , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) @@ -309,7 +310,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' ; let e_ty = mkInfForAllTy alphaTyVar $ - mkVisFunTys cmd_tys $ + mkVisFunTysMany cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcCheckPolyExpr expr e_ty ; return (HsCmdArrForm x expr' f fixity cmd_args') } @@ -340,7 +341,7 @@ tcCmdMatches :: CmdEnv -> CmdType -> TcM (MatchGroup GhcTcId (LHsCmd GhcTcId)) tcCmdMatches env scrut_ty matches (stk, res_ty) - = tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) + = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } @@ -382,7 +383,7 @@ tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } @@ -390,7 +391,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names }) res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + ; let tup_ids = zipWith (\n p -> mkLocalId n Many p) tup_names tup_elt_tys -- Many because it's a recursive definition ; tcExtendIdEnv tup_ids $ do { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> @@ -439,7 +440,7 @@ mkPairTy :: Type -> Type -> Type mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] arrowTyConKind :: Kind -- *->*->* -arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind +arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind {- ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index b88a672795..b87db660e2 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -41,6 +41,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType +import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Core.TyCon @@ -398,6 +399,9 @@ tcValBinds top_lvl binds sigs thing_inside -- Do not extend the TcBinderStack; instead -- we extend it on a per-rhs basis in tcExtendForRhs -- See Note [Relevant bindings and the binder stack] + -- + -- For the moment, let bindings and top-level bindings introduce + -- only unrestricted variables. ; tcExtendSigIds top_lvl poly_ids $ do { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ @@ -497,9 +501,10 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing) go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc - ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn - closed ids1 $ - go sccs + -- recursive bindings must be unrestricted + -- (the ids added to the environment here are the name of the recursive definitions). + ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn closed ids1 + (go sccs) ; return (binds1 `unionBags` binds2, thing) } go [] = do { thing <- thing_inside; return (emptyBag, thing) } @@ -541,6 +546,8 @@ tc_single top_lvl sig_fn prag_fn lbind closed thing_inside NonRecursive NonRecursive closed [lbind] + -- since we are defining a non-recursive binding, it is not necessary here + -- to define an unrestricted binding. But we do so until toplevel linear bindings are supported. ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside ; return (binds1, thing) } @@ -633,7 +640,7 @@ recoveryCode binder_names sig_fn , Just poly_id <- completeSigPolyId_maybe sig = poly_id | otherwise - = mkLocalId name forall_a_a + = mkLocalId name Many forall_a_a forall_a_a :: TcType -- At one point I had (forall r (a :: TYPE r). a), but of course @@ -703,7 +710,7 @@ tcPolyCheck prag_fn -- NB: tcSkolemise makes fresh type variables -- See Note [Instantiate sig with fresh variables] - let mono_id = mkLocalId mono_name rho_ty in + let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ -- Why mono_id in the BinderStack? -- See Note [Relevant bindings and the binder stack] @@ -719,7 +726,7 @@ tcPolyCheck prag_fn -- We re-use mono-name, but we could equally well use a fresh one ; let prag_sigs = lookupPragEnv prag_fn name - poly_id2 = mkLocalId mono_name (idType poly_id) + poly_id2 = mkLocalId mono_name (idMult poly_id) (idType poly_id) ; spec_prags <- tcSpecPrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs @@ -933,7 +940,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty -- do this check; otherwise (#14000) we may report an ambiguity -- error for a rather bogus type. - ; return (mkLocalId poly_name inferred_poly_ty) } + ; return (mkLocalId poly_name Many inferred_poly_ty) } chooseInferredQuantifiers :: TcThetaType -- inferred @@ -1288,7 +1295,7 @@ tcMonoBinds is_rec sig_fn no_gen -- type of the thing whose rhs we are type checking tcMatchesFun (L nm_loc name) matches exp_ty - ; mono_id <- newLetBndr no_gen name rhs_ty + ; mono_id <- newLetBndr no_gen name Many rhs_ty ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', @@ -1361,7 +1368,10 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name mono_ty + ; mono_id <- newLetBndr no_gen name Many mono_ty + -- This ^ generates a binder with Many multiplicity because all + -- let/where-binders are unrestricted. When we introduce linear let + -- binders, we will need to retrieve the multiplicity information. ; let mono_info = MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id } @@ -1379,7 +1389,10 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) ; ((pat', nosig_mbis), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ tcInfer $ \ exp_ty -> - tcLetPat inst_sig_fun no_gen pat exp_ty $ + tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $ + -- The above inferred type get an unrestricted multiplicity. It may be + -- worth it to try and find a finer-grained multiplicity here + -- if examples warrant it. mapM lookup_info nosig_names ; let mbis = sig_mbis ++ nosig_mbis @@ -1426,7 +1439,10 @@ newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) | CompleteSig { sig_bndr = poly_id } <- id_sig = addInlinePrags poly_id (lookupPragEnv prags name) newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) - = newLetBndr no_gen name tau + = newLetBndr no_gen name Many tau + -- Binders with a signature are currently always of multiplicity + -- Many. Because they come either from toplevel, let, or where + -- declarations. Which are all unrestricted currently. ------------------- tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId) @@ -1450,6 +1466,12 @@ tcRhs (TcPatBind infos pat' grhss pat_ty) tcExtendIdBinderStackForRhs infos $ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcScalingUsage Many $ + -- Like in tcMatchesFun, this scaling happens because all + -- let bindings are unrestricted. A difference, here, is + -- that when this is not the case, any more, we will have to + -- make sure that the pattern is strict, otherwise this will + -- be desugar to incorrect code. tcGRHSsPat grhss pat_ty ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' , pat_ext = NPatBindTc emptyNameSet pat_ty diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 9294d5fe64..477c8eaa1d 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -35,6 +35,8 @@ import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds ) import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig ) @@ -69,6 +71,7 @@ import GHC.Core.Type import GHC.Tc.Types.Evidence import GHC.Types.Var.Set import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( multiplicityTyVarList ) import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names import GHC.Driver.Session @@ -218,8 +221,8 @@ tcExpr (HsOverLit x lit) res_ty tcExpr (NegApp x expr neg_expr) res_ty = do { (expr', neg_expr') <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ - \[arg_ty] -> - tcLExpr expr (mkCheckExpType arg_ty) + \[arg_ty] [arg_mult] -> + tcScalingUsage arg_mult $ tcLExpr expr (mkCheckExpType arg_ty) ; return (NegApp x expr' neg_expr') } tcExpr e@(HsIPVar _ x) res_ty @@ -362,6 +365,13 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty ; (wrap_arg1, [arg2_sigma], op_res_ty) <- matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty + ; mult_wrap <- tcSubMult AppOrigin Many (scaledMult arg2_sigma) + -- See Note [tcSubMult's wrapper] in TcUnify. + -- + -- When ($) becomes multiplicity-polymorphic, then the above check will + -- need to go. But in the meantime, it would produce ill-typed + -- desugared code to accept linear functions to the left of a ($). + -- We have (arg1 $ arg2) -- So: arg1_ty = arg2_ty -> op_res_ty -- where arg2_sigma maybe polymorphic; that's the point @@ -372,8 +382,8 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b -- Eg we do not want to allow (D# $ 4.0#) #5570 -- (which gives a seg fault) - ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) - (tcTypeKind arg2_sigma) liftedTypeKind + ; _ <- unifyKind (Just (XHsType $ NHsCoreTy (scaledThing arg2_sigma))) + (tcTypeKind (scaledThing arg2_sigma)) liftedTypeKind -- Ignore the evidence. arg2_sigma must have type * or #, -- because we know (arg2_sigma -> op_res_ty) is well-kinded -- (because otherwise matchActualFunTysRho would fail) @@ -385,14 +395,14 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty ; op_id <- tcLookupId op_name ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty - , arg2_sigma + , scaledThing arg2_sigma , op_res_ty]) (HsVar noExtField (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty - expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' + expr' = OpApp fix (mkLHsWrap (wrap_arg1 <.> mult_wrap) arg1') op' arg2' ; tcWrapResult expr expr' op_res_ty res_ty } @@ -430,12 +440,12 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty tcExpr expr@(SectionR x op arg2) res_ty = do { (op', op_ty) <- tcInferRhoNC op - ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) + ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty) <- matchActualFunTysRho (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty ; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2 ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2' - act_res_ty = mkVisFunTy arg1_ty op_res_ty + act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty ; tcWrapResultMono expr expr' act_res_ty res_ty } where @@ -491,14 +501,21 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys ; let expr' = ExplicitTuple x tup_args1 boxity - act_res_ty = mkVisFunTys [ty | (ty, (L _ (Missing _))) - <- arg_tys `zip` tup_args] - (mkTupleTy1 boxity arg_tys) + + missing_tys = [ty | (ty, L _ (Missing _)) <- zip arg_tys tup_args] + w_tyvars = multiplicityTyVarList (length missing_tys) + -- See Note [Linear fields generalization] + w_tvb = map (mkTyVarBinder Inferred) w_tyvars + act_res_ty + = mkForAllTys w_tvb $ + mkVisFunTys [ mkScaled (mkTyVarTy w_ty) ty | + (ty, w_ty) <- zip missing_tys w_tyvars] + (mkTupleTy1 boxity arg_tys) -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) - ; tcWrapResultMono expr expr' act_res_ty res_ty } + ; tcWrapResult expr expr' act_res_ty res_ty } tcExpr (ExplicitSum _ alt arity expr) res_ty = do { let sum_tc = sumTyCon arity @@ -522,9 +539,15 @@ tcExpr (ExplicitList _ witness exprs) res_ty Just fln -> do { ((exprs', elt_ty), fln') <- tcSyntaxOp ListOrigin fln [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] -> + \ [elt_ty] [_int_mul, list_mul] -> + -- We ignore _int_mul because the integer (first + -- argument of fromListN) is statically known: it + -- is desugared to a literal. Therefore there is + -- no variable of which to scale the usage in that + -- first argument, and `_int_mul` is completely + -- free in this expression. do { exprs' <- - mapM (tc_elt elt_ty) exprs + mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs ; return (exprs', elt_ty) } ; return $ ExplicitList elt_ty (Just fln') exprs' } @@ -553,6 +576,9 @@ tcExpr (HsCase x scrut matches) res_ty -- -- But now, in the GADT world, we need to typecheck the scrutinee -- first, to get type info that may be refined in the case alternatives + let mult = Many + -- There is not yet syntax or inference mechanism for case + -- expressions to be anything else than unrestricted. -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma -- would also be possible (tcMatchesCase accepts sigma-types) @@ -560,10 +586,10 @@ tcExpr (HsCase x scrut matches) res_ty -- case id of {..} -- case (\v -> v) of {..} -- This design choice is discussed in #17790 - (scrut', scrut_ty) <- tcInferRho scrut + ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty + ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty ; return (HsCase x scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, @@ -575,17 +601,18 @@ tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' -- Just like Note [Case branches must never infer a non-tau type] -- in GHC.Tc.Gen.Match (See #10619) - ; b1' <- tcLExpr b1 res_ty - ; b2' <- tcLExpr b2 res_ty + ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty + ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty + ; tcEmitBindingUsage (supUE u1 u2) ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty = do { ((pred', b1', b2'), fun') <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ - \ [pred_ty, b1_ty, b2_ty] -> - do { pred' <- tcCheckPolyExpr pred pred_ty - ; b1' <- tcCheckPolyExpr b1 b1_ty - ; b2' <- tcCheckPolyExpr b2 b2_ty + \ [pred_ty, b1_ty, b2_ty] [pred_mult, b1_mult, b2_mult] -> + do { pred' <- tcScalingUsage pred_mult $ tcCheckPolyExpr pred pred_ty + ; b1' <- tcScalingUsage b1_mult $ tcCheckPolyExpr b1 b1_ty + ; b2' <- tcScalingUsage b2_mult $ tcCheckPolyExpr b2 b2_ty ; return (pred', b1', b2') } ; return (HsIf x fun' pred' b1' b2') } @@ -679,7 +706,12 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name Nothing -> nonBidirectionalErr (conLikeName con_like) ; Just con_id -> - do { rbinds' <- tcRecordBinds con_like arg_tys rbinds + do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds + -- It is currently not possible for a record to have + -- multiplicities. When they do, `tcRecordBinds` will take + -- scaled types instead. Meanwhile, it's safe to take + -- `scaledThing` above, as we know all the multiplicities are + -- Many. ; let rcon_tc = RecordConTc { rcon_con_like = con_like , rcon_con_expr = mkHsWrap con_wrap con_expr } @@ -829,7 +861,20 @@ following. tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty = ASSERT( notNull rbnds ) do { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcInferRho record_expr + (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr + -- Record update drops some of the content of the record (namely the + -- content of the field being updated). As a consequence, unless the + -- field being updated is unrestricted in the record, or we need an + -- unrestricted record. Currently, we simply always require an + -- unrestricted record. + -- + -- Consider the following example: + -- + -- data R a = R { self :: a } + -- bad :: a ⊸ () + -- bad x = let r = R x in case r { self = () } of { R x' -> x' } + -- + -- This should definitely *not* typecheck. -- STEP -1 See Note [Disambiguating record fields] -- After this we know that rbinds is unambiguous @@ -886,8 +931,13 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Take apart a representative constructor ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) + (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _) = conLikeFullSig con1 + con1_arg_tys = map scaledThing scaled_con1_arg_tys + -- We can safely drop the fields' multiplicities because + -- they are currently always 1: there is no syntax for record + -- fields with other multiplicities yet. This way we don't need + -- to handle it in the rest of the function con1_flds = map flLabel $ conLikeFieldLabels con1 con1_tv_tys = mkTyVarTys con1_tvs con1_res_ty = case mtycon of @@ -1069,36 +1119,36 @@ tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcArithSeq witness seq@(From expr) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr' <- tcCheckPolyExpr expr elt_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) enumFromName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from wit' (From expr') } tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcCheckPolyExpr expr1 elt_ty - ; expr2' <- tcCheckPolyExpr expr2 elt_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) enumFromThenName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from_then wit' (FromThen expr1' expr2') } tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcCheckPolyExpr expr1 elt_ty - ; expr2' <- tcCheckPolyExpr expr2 elt_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) enumFromToName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from_to wit' (FromTo expr1' expr2') } tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcCheckPolyExpr expr1 elt_ty - ; expr2' <- tcCheckPolyExpr expr2 elt_ty - ; expr3' <- tcCheckPolyExpr expr3 elt_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName [elt_ty] ; return $ mkHsWrap wrap $ @@ -1106,16 +1156,16 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty ----------------- arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType - -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) + -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc)) arithSeqEltType Nothing res_ty = do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, elt_ty, Nothing) } + ; return (mkWpCastN coi, One, elt_ty, Nothing) } arithSeqEltType (Just fl) res_ty - = do { (elt_ty, fl') + = do { ((elt_mult, elt_ty), fl') <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ - \ [elt_ty] -> return elt_ty - ; return (idHsWrapper, elt_ty, Just fl') } + \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) + ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } {- ************************************************************************ @@ -1346,7 +1396,7 @@ tcArgs fun orig_fun_ty orig_args _ -> False go :: Int -- Which argment number this is (incl type args) - -> [TcSigmaType] -- Value args to which applied so far + -> [Scaled TcSigmaType] -- Value args to which applied so far -> TcSigmaType -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType) go _ _ fun_ty [] = traceTc "tcArgs:ret" (ppr fun_ty) >> return ([], fun_ty) @@ -1491,16 +1541,16 @@ and we had the visible type application ---------------- tcArg :: HsExpr GhcRn -- The function (for error messages) -> LHsExpr GhcRn -- Actual arguments - -> TcSigmaType -- expected arg type + -> Scaled TcSigmaType -- expected arg type -> Int -- # of argument -> TcM (LHsExpr GhcTc) -- Resulting argument -tcArg fun arg ty arg_no +tcArg fun arg (Scaled mult ty) arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ do { traceTc "tcArg" $ vcat [ ppr arg_no <+> text "of" <+> ppr fun , text "arg type:" <+> ppr ty , text "arg:" <+> ppr arg ] - ; tcCheckPolyExprNC arg ty } + ; tcScalingUsage mult $ tcCheckPolyExprNC arg ty } ---------------- tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] @@ -1517,7 +1567,10 @@ tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpRhoType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments, + -- takes a type per hole and a + -- multiplicity per arrow in + -- the shape. -> TcM (a, SyntaxExprTc) -- ^ Typecheck a syntax operator -- The operator is a variable or a lambda at this stage (i.e. renamer @@ -1531,7 +1584,7 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) + -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferAppHead op @@ -1560,7 +1613,7 @@ two tcSynArgs. tcSynArgE :: CtOrigin -> TcSigmaType -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper) -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) tcSynArgE orig sigma_ty syn_ty thing_inside @@ -1570,26 +1623,26 @@ tcSynArgE orig sigma_ty syn_ty thing_inside ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny - = do { result <- thing_inside [rho_ty] + = do { result <- thing_inside [rho_ty] [] ; return (result, idHsWrapper) } go rho_ty SynRho -- same as SynAny, because we skolemise eagerly - = do { result <- thing_inside [rho_ty] + = do { result <- thing_inside [rho_ty] [] ; return (result, idHsWrapper) } go rho_ty SynList = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty - ; result <- thing_inside [elt_ty] + ; result <- thing_inside [elt_ty] [] ; return (result, mkWpCastN list_co) } go rho_ty (SynFun arg_shape res_shape) = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty - , ( ( (result, arg_ty, res_ty) + , ( ( (result, arg_ty, res_ty, op_mult) , res_wrapper ) -- :: res_ty_out "->" res_ty , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ \ [arg_ty] res_ty -> - do { arg_tc_ty <- expTypeToType arg_ty + do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) ; res_tc_ty <- expTypeToType res_ty -- another nested arrow is too much for now, @@ -1600,24 +1653,25 @@ tcSynArgE orig sigma_ty syn_ty thing_inside , text "Too many nested arrows in SyntaxOpType" $$ pprCtOrigin orig ) + ; let arg_mult = scaledMult arg_ty ; tcSynArgA orig arg_tc_ty [] arg_shape $ - \ arg_results -> + \ arg_results arg_res_mults -> tcSynArgE orig res_tc_ty res_shape $ - \ res_results -> - do { result <- thing_inside (arg_results ++ res_results) - ; return (result, arg_tc_ty, res_tc_ty) }} + \ res_results res_res_mults -> + do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) + ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} ; return ( result , match_wrapper <.> mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - arg_ty res_ty doc ) } + (Scaled op_mult arg_ty) res_ty doc ) } where herald = text "This rebindable syntax expects a function with" doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty - ; result <- thing_inside [] + ; result <- thing_inside [] [] ; return (result, wrap) } -- works on "actual" types, instantiating where necessary @@ -1626,7 +1680,7 @@ tcSynArgA :: CtOrigin -> TcSigmaType -> [SyntaxOpType] -- ^ argument shapes -> SyntaxOpType -- ^ result shape - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) -- ^ returns a wrapper to be applied to the original function, -- wrappers to be applied to arguments @@ -1637,24 +1691,24 @@ tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside (length arg_shapes) sigma_ty -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) ; ((result, res_wrapper), arg_wrappers) - <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> + <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> tc_syn_arg res_ty res_shape $ \ res_results -> - thing_inside (arg_results ++ res_results) + thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where herald = text "This rebindable syntax expects a function with" tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] - -> ([TcSigmaType] -> TcM a) + -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, [HsWrapper]) -- the wrappers are for arguments tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results -> - thing_inside (arg1_results ++ args_results) + <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> + thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) ; return (result, arg_wrap : arg_wraps) } - tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] + tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] tc_syn_arg :: TcSigmaType -> SyntaxOpType -> ([TcSigmaType] -> TcM a) @@ -1817,7 +1871,7 @@ tcCheckRecSelId rn_expr f@(Unambiguous {}) res_ty tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of Nothing -> ambiguousSelector lbl - Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg + Just (arg, _) -> do { sel_name <- disambiguateSelector lbl (scaledThing arg) ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) res_ty } @@ -1862,6 +1916,7 @@ tc_infer_id lbl id_name ATcId { tct_id = id } -> do { check_naughty id -- Note [Local record selectors] ; checkThLocalId id + ; tcEmitBindingUsage $ unitUE id_name One ; return_id id } AGlobal (AnId id) @@ -1881,25 +1936,47 @@ tc_infer_id lbl id_name return_id id = return (HsVar noExtField (noLoc id), idType id) return_data_con con - -- For data constructors, must perform the stupid-theta check - | null stupid_theta - = return (HsConLikeOut noExtField (RealDataCon con), con_ty) - - | otherwise - -- See Note [Instantiating stupid theta] - = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty - ; (subst, tvs') <- newMetaTyVars tvs - ; let tys' = mkTyVarTys tvs' - theta' = substTheta subst theta - rho' = substTy subst rho - ; wrap <- instCall (OccurrenceOf id_name) tys' theta' - ; addDataConStupidTheta con tys' - ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) - , rho') } - - where - con_ty = dataConUserType con - stupid_theta = dataConStupidTheta con + = do { let tvs = dataConUserTyVarBinders con + theta = dataConOtherTheta con + args = dataConOrigArgTys con + res = dataConOrigResTy con + + -- See Note [Linear fields generalization] + ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy + ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args' + combine var (Scaled One ty) = Scaled var ty + combine _ scaled_ty = scaled_ty + -- The combine function implements the fact that, as + -- described in Note [Linear fields generalization], if a + -- field is not linear (last line) it isn't made polymorphic. + + etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys + + -- See Note [Instantiating stupid theta] + ; let shouldInstantiate = (not (null (dataConStupidTheta con)) || + isKindLevPoly (tyConResKind (dataConTyCon con))) + ; case shouldInstantiate of + True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs) + ; let tys' = mkTyVarTys tvs' + theta' = substTheta subst theta + args' = substScaledTys subst args + res' = substTy subst res + ; wrap <- instCall (OccurrenceOf id_name) tys' theta' + ; let scaled_arg_tys = scaleArgs args' + eta_wrap = etaWrapper scaled_arg_tys + ; addDataConStupidTheta con tys' + ; return ( mkHsWrap (eta_wrap <.> wrap) + (HsConLikeOut noExtField (RealDataCon con)) + , mkVisFunTys scaled_arg_tys res') + } + False -> let scaled_arg_tys = scaleArgs args + wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs) + eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys) + wrap2 = mkWpTyLams $ binderVars tvs + in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1) + (HsConLikeOut noExtField (RealDataCon con)) + , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res) + } check_naughty id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) @@ -1918,7 +1995,7 @@ tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc) tcUnboundId rn_expr occ res_ty = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) ; name <- newSysName occ - ; let ev = mkLocalId name ty + ; let ev = mkLocalId name Many ty ; emitNewExprHole occ ev ty ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExtField (noLoc ev)) ty res_ty } @@ -1972,6 +2049,42 @@ in this case. Thus, users cannot use visible type application with a data constructor sporting a stupid theta. I won't feel so bad for the users that complain. +Note [Linear fields generalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Polymorphisation of linear fields], linear field of data +constructors get a polymorphic type when the data constructor is used as a term. + + Just :: forall {p} a. a #p-> Maybe a + +This rule is known only to the typechecker: Just keeps its linear type in Core. + +In order to desugar this generalised typing rule, we simply eta-expand: + + \a (x # p :: a) -> Just @a x + +has the appropriate type. We insert these eta-expansion with WpFun wrappers. + +A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums, +certain newtypes with -XUnliftedNewtypes) then this strategy produces + + \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #) + +Which has type + + forall r1 r2 a b. a #p-> b #q-> (# a, b #) + +Which violates the levity-polymorphism restriction see Note [Levity polymorphism +checking] in DsMonad. + +So we really must instantiate r1 and r2 rather than quantify over them. For +simplicity, we just instantiate the entire type, as described in Note +[Instantiating stupid theta]. It breaks visible type application with unboxed +tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used +anywhere. + +A better plan: let's force all representation variable to be *inferred*, so that +they are not subject to visible type applications. Then we can instantiate +inferred argument eagerly. -} isTagToEnum :: HsExpr GhcTc -> Bool @@ -2149,7 +2262,7 @@ getFixedTyVars upd_fld_occs univ_tvs cons ++ prov_theta ++ req_theta flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes fixed_tys + fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys) -- fixed_tys: See Note [Type of a record update] `unionVarSet` tyCoVarsOfTypes theta -- Universally-quantified tyvars that @@ -2497,7 +2610,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs do { rhs' <- tcCheckPolyExprNC rhs field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) - field_ty loc + Many field_ty loc -- Yuk: the field_id has the *unique* of the selector Id -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot index 1f26ef242a..f4b12e28a5 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs-boot +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -4,6 +4,7 @@ import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Core.Type ( Mult ) import GHC.Hs.Extension ( GhcRn, GhcTcId ) tcCheckPolyExpr :: @@ -31,14 +32,14 @@ tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments -> TcM (a, SyntaxExprTc) tcSyntaxOpGen :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) + -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 06febcef33..97757c0889 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -46,6 +46,7 @@ import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Types.ForeignCall import GHC.Utils.Error import GHC.Types.Id @@ -93,20 +94,6 @@ parameters. Similarly, we don't need to look in AppTy's, because nothing headed by an AppTy will be marshalable. - -Note [FFI type roles] -~~~~~~~~~~~~~~~~~~~~~ -The 'go' helper function within normaliseFfiType' always produces -representational coercions. But, in the "children_only" case, we need to -use these coercions in a TyConAppCo. Accordingly, the roles on the coercions -must be twiddled to match the expectation of the enclosing TyCon. However, -we cannot easily go from an R coercion to an N one, so we forbid N roles -on FFI type constructors. Currently, only two such type constructors exist: -IO and FunPtr. Thus, this is not an onerous burden. - -If we ever want to lift this restriction, we would need to make 'go' take -the target role as a parameter. This wouldn't be hard, but it's a complication -not yet necessary and so is not yet implemented. -} -- normaliseFfiType takes the type from an FFI declaration, and @@ -120,33 +107,31 @@ normaliseFfiType ty normaliseFfiType' fam_envs ty normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType' env ty0 = go initRecTc ty0 +normaliseFfiType' env ty0 = go Representational initRecTc ty0 where - go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) - go rec_nts ty + go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) + go role rec_nts ty | Just ty' <- tcView ty -- Expand synonyms - = go rec_nts ty' + = go role rec_nts ty' | Just (tc, tys) <- splitTyConApp_maybe ty - = go_tc_app rec_nts tc tys + = go_tc_app role rec_nts tc tys | (bndrs, inner_ty) <- splitForAllVarBndrs ty , not (null bndrs) - = do (coi, nty1, gres1) <- go rec_nts inner_ty + = do (coi, nty1, gres1) <- go role rec_nts inner_ty return ( mkHomoForAllCos (binderVars bndrs) coi , mkForAllTys bndrs nty1, gres1 ) | otherwise -- see Note [Don't recur in normaliseFfiType'] - = return (mkRepReflCo ty, ty, emptyBag) + = return (mkReflCo role ty, ty, emptyBag) - go_tc_app :: RecTcChecker -> TyCon -> [Type] + go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] -> TcM (Coercion, Type, Bag GlobalRdrElt) - go_tc_app rec_nts tc tys + go_tc_app role rec_nts tc tys -- We don't want to look through the IO newtype, even if it is -- in scope, so we have a special case for it: | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] - -- These *must not* have nominal roles on their parameters! - -- See Note [FFI type roles] = children_only | isNewTyCon tc -- Expand newtypes @@ -160,13 +145,13 @@ normaliseFfiType' env ty0 = go initRecTc ty0 = do { rdr_env <- getGlobalRdrEnv ; case checkNewtypeFFI rdr_env tc of Nothing -> nothing - Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs + Just gre -> do { (co', ty', gres) <- go role rec_nts' nt_rhs ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env Representational tc tys + , (co, ty) <- normaliseTcApp env role tc tys , not (isReflexiveCo co) - = do (co', ty', gres) <- go rec_nts ty + = do (co', ty', gres) <- go role rec_nts ty return (mkTransCo co co', ty', gres) | otherwise @@ -174,19 +159,15 @@ normaliseFfiType' env ty0 = go initRecTc ty0 where tc_key = getUnique tc children_only - = do xs <- mapM (go rec_nts) tys + = do xs <- zipWithM (\ty r -> go r rec_nts ty) tys (tyConRolesX role tc) let (cos, tys', gres) = unzip3 xs - -- the (repeat Representational) is because 'go' always - -- returns R coercions - cos' = zipWith3 downgradeRole (tyConRoles tc) - (repeat Representational) cos - return ( mkTyConAppCo Representational tc cos' + return ( mkTyConAppCo role tc cos , mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] + nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys [] nt_rhs = newTyConInstRhs tc tys ty = mkTyConApp tc tys - nothing = return (mkRepReflCo ty, ty, emptyBag) + nothing = return (mkReflCo role ty, ty, emptyBag) checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI rdr_env tc @@ -251,12 +232,12 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty -- Drop the foralls before inspecting the -- structure of the foreign type. (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) - id = mkLocalId nm sig_ty + id = mkLocalId nm Many sig_ty -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it). - ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl + ; imp_decl' <- tcCheckFIType (map scaledThing arg_tys) res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and -- we need HsType Id hence the undefined ; let fi_decl = ForeignImport { fd_name = L nloc id @@ -275,7 +256,7 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) = do checkCg checkCOrAsmOrLlvmOrInterp -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) + check (isFFILabelTy (mkVisFunTysMany arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) cconv' <- checkCConv cconv return (CImport (L lc cconv') safety mh l src) @@ -287,7 +268,7 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of - [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys + [arg1_ty] -> do checkForeignArgs isFFIExternalTy (map scaledThing arg1_tys) checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where @@ -305,7 +286,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) (arg1_ty:arg_tys) -> do dflags <- getDynFlags - let curried_res_ty = mkVisFunTys arg_tys res_ty + let curried_res_ty = mkVisFunTysMany arg_tys res_ty check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -418,7 +399,7 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do checkCg checkCOrAsmOrLlvm checkTc (isCLabelString str) (badCName str) cconv' <- checkCConv cconv - checkForeignArgs isFFIExternalTy arg_tys + checkForeignArgs isFFIExternalTy (map scaledThing arg_tys) checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty return (CExport (L l (CExportStatic esrc str cconv')) src) where diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index b99cc6365b..fecd8b9b2e 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -57,6 +57,9 @@ module GHC.Tc.Gen.HsType ( tcLHsKindSig, checkDataKindSig, DataSort(..), checkClassKindSig, + -- Multiplicity + tcMult, + -- Pattern type signatures tcHsPatSigType, @@ -85,6 +88,7 @@ import GHC.Core.TyCo.Ppr import GHC.Tc.Errors ( reportAllUnsolved ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) +import GHC.Core.Multiplicity import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Name.Reader( lookupLocalRdrOcc ) @@ -469,7 +473,7 @@ tcHsDeriv hs_ty ; let (tvs, pred) = splitForAllTys ty (kind_args, _) = splitFunTys (tcTypeKind pred) ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, kind_args) + Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } -- | Typecheck a deriving strategy. For most deriving strategies, this is a @@ -684,6 +688,9 @@ concern things that the renamer can't handle. -} +tcMult :: HsArrow GhcRn -> TcM Mult +tcMult hc = tc_mult (mkMode TypeLevel) hc + -- | Info about the context in which we're checking a type. Currently, -- differentiates only between types and kinds, but this will likely -- grow, at least to include the distinction between patterns and @@ -888,12 +895,15 @@ tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind = failWithTc (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications -tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind - = tc_fun_type mode ty1 ty2 exp_kind +tc_hs_type mode ty@(HsFunTy _ mult ty1 ty2) exp_kind + | mode_tyki mode == KindLevel && not (isUnrestricted mult) + = failWithTc (text "Linear arrows disallowed in kinds:" <+> ppr ty) + | otherwise + = tc_fun_type mode mult ty1 ty2 exp_kind tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind | op `hasKey` funTyConKey - = tc_fun_type mode ty1 ty2 exp_kind + = tc_fun_type mode HsUnrestrictedArrow ty1 ty2 exp_kind --------- Foralls tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind @@ -1084,20 +1094,25 @@ Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo. -} ------------------------------------------ -tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind +tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult +tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy +------------------------------------------ +tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind -> TcM TcType -tc_fun_type mode ty1 ty2 exp_kind = case mode_tyki mode of +tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of TypeLevel -> do { arg_k <- newOpenTypeKind ; res_k <- newOpenTypeKind ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') + ; mult' <- tc_mult mode mult + ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') + ; mult' <- tc_mult mode mult + ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } {- Note [Skolem escape and forall-types] @@ -2128,7 +2143,7 @@ kcCheckDeclHeader_cusk name flav ++ mkNamedTyConBinders Specified specified ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs True -- it is generalised flav @@ -2363,7 +2378,7 @@ kcCheckDeclHeader_sig kisig name flav -- Example: (a~b) => ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do name <- newSysName (mkTyVarOccFS (fsLit "ev")) - let tv = mkTyVar name bndr_ki + let tv = mkTyVar name (scaledThing bndr_ki) return (mkAnonTyConBinder InvisArg tv, []) -- Non-dependent visible argument with a user-written binder. @@ -2371,7 +2386,7 @@ kcCheckDeclHeader_sig kisig name flav ZippedBinder (Anon VisArg bndr_ki) (Just b) -> return $ let v_name = getName b - tv = mkTyVar v_name bndr_ki + tv = mkTyVar v_name (scaledThing bndr_ki) tcb = mkAnonTyConBinder VisArg tv in (tcb, [(v_name, tv)]) @@ -3181,7 +3196,7 @@ etaExpandAlgTyCon tc_bndrs kind Just (Anon af arg, kind') -> go loc occs' uniqs' subst' (tcb : acc) kind' where - arg' = substTy subst arg + arg' = substTy subst (scaledThing arg) tv = mkTyVar (mkInternalName uniq occ loc) arg' subst' = extendTCvInScope subst tv tcb = Bndr tv (AnonTCB af) diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index b95899cc1f..0bff299886 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -51,6 +51,8 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv import GHC.Types.Name import GHC.Builtin.Types import GHC.Types.Id @@ -100,6 +102,13 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that + tcScalingUsage Many $ + -- toplevel bindings and let bindings are, at the + -- moment, always unrestricted. The value being bound + -- must, accordingly, be unrestricted. Hence them + -- being scaled by Many. When let binders come with a + -- multiplicity, then @tcMatchesFun@ will have to take + -- a multiplicity argument, and scale accordingly. tcMatches match_ctxt pat_tys rhs_ty matches } where arity = matchGroupArity matches @@ -122,16 +131,16 @@ parser guarantees that each equation has exactly one argument. -} tcMatchesCase :: (Outputable (body GhcRn)) => - TcMatchCtxt body -- Case context - -> TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -- Translated alternatives - -- wrapper goes from MatchGroup's ty to expected ty + TcMatchCtxt body -- Case context + -> Scaled TcSigmaType -- Type of scrutinee + -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives + -> ExpRhoType -- Type of whole case expressions + -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) + -- Translated alternatives + -- wrapper goes from MatchGroup's ty to expected ty -tcMatchesCase ctxt scrut_ty matches res_ty - = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches +tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty + = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr @@ -197,15 +206,16 @@ still gets assigned a polytype. -- expected type into TauTvs. -- See Note [Case branches must never infer a non-tau type] tauifyMultipleMatches :: [LMatch id body] - -> [ExpType] -> TcM [ExpType] + -> [Scaled ExpType] -> TcM [Scaled ExpType] tauifyMultipleMatches group exp_tys | isSingletonMatchGroup group = return exp_tys - | otherwise = mapM tauifyExpType exp_tys + | otherwise = mapM (\(Scaled m t) -> + fmap (Scaled m) (tauifyExpType t)) exp_tys -- NB: In the empty-match case, this ensures we fill in the ExpType -- | Type-check a MatchGroup. tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types + -> [Scaled ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> MatchGroup GhcRn (Located (body GhcRn)) -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) @@ -216,14 +226,15 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module -- an alternative -> ExpRhoType -> TcM (Located (body GhcTcId)) } - tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) - = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) + = do { (Scaled _ rhs_ty):pat_tys <- tauifyMultipleMatches matches ((Scaled One rhs_ty):pat_tys) -- return type has implicitly multiplicity 1, it doesn't matter all that much in this case since it isn't used and is eliminated immediately. -- See Note [Case branches must never infer a non-tau type] - ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; pat_tys <- mapM readExpType pat_tys + ; umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches + ; let (usages,matches') = unzip umatches + ; tcEmitBindingUsage $ supUEs usages + ; pat_tys <- mapM (\(Scaled m t) -> fmap (Scaled m) (readExpType t)) pat_tys ; rhs_ty <- readExpType rhs_ty ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty @@ -231,7 +242,7 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ------------- tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types + -> [Scaled ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> LMatch GhcRn (Located (body GhcRn)) -> TcM (LMatch GhcTcId (Located (body GhcTcId))) @@ -266,10 +277,11 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType -- but we don't need to do that any more tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty - = do { (binds', grhss') + = do { (binds', ugrhss) <- tcLocalBinds binds $ - mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - + mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss + ; let (usages, grhss') = unzip ugrhss + ; tcEmitBindingUsage $ supUEs usages ; return (GRHSs noExtField grhss' (L l binds')) } ------------- @@ -412,7 +424,7 @@ tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) - pat rhs_ty $ + pat (unrestricted rhs_ty) $ thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } @@ -445,7 +457,7 @@ tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ thing_inside elt_ty ; return (mkTcBindStmt pat' rhs', thing) } @@ -500,14 +512,14 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present by_arrow = case by' of Nothing -> \ty -> ty - Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty + Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy poly_res_ty = m_app (n_app alphaTy) using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty + poly_arg_ty `mkVisFunTyMany` poly_res_ty ; using' <- tcCheckPolyExpr using using_poly_ty ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' @@ -516,7 +528,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts -- typically something like [(Int,Bool,Int)] -- We don't know what tuple_ty is yet, so we use a variable ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -550,8 +562,8 @@ tcMcStmt :: TcExprStmtChecker tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside = do { (body', return_op') <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ - \ [a_ty] -> - tcCheckMonoExprNC body a_ty + \ [a_ty] [mult]-> + tcScalingUsage mult $ tcCheckMonoExprNC body a_ty ; thing <- thing_inside (panic "tcMcStmt: thing_inside") ; return (LastStmt x body' noret return_op', thing) } @@ -563,14 +575,14 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - = do { ((rhs', pat', thing, new_res_ty), bind_op') + = do { ((rhs', pat_mult, pat', thing, new_res_ty), bind_op') <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcCheckMonoExprNC rhs rhs_ty - ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] -> + do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', thing, new_res_ty) } + ; return (rhs', pat_mult, pat', thing, new_res_ty) } -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> @@ -579,6 +591,7 @@ tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside ; let xbstc = XBindStmtTc { xbstc_bindOp = bind_op' , xbstc_boundResultType = new_res_ty + , xbstc_boundResultMult = pat_mult , xbstc_failOp = fail_op' } ; return (BindStmt xbstc pat' rhs', thing) } @@ -594,13 +607,14 @@ tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside -- Where test_ty is, for example, Bool ; ((thing, rhs', rhs_ty, guard_op'), then_op') <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> + \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] -> do { (rhs', guard_op') - <- tcSyntaxOp MCompOrigin guard_op [SynAny] + <- tcScalingUsage rhs_mult $ + tcSyntaxOp MCompOrigin guard_op [SynAny] (mkCheckExpType rhs_ty) $ - \ [test_ty] -> - tcCheckMonoExpr rhs test_ty - ; thing <- thing_inside (mkCheckExpType new_res_ty) + \ [test_ty] [test_mult] -> + tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty + ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) ; return (thing, rhs', rhs_ty, guard_op') } ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } @@ -640,7 +654,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- or res ('by' absent) by_arrow = case by of Nothing -> \res -> res - Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res + Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res poly_arg_ty = m1_ty `mkAppTy` alphaTy using_arg_ty = m1_ty `mkAppTy` tup_ty @@ -648,7 +662,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap using_res_ty = m2_ty `mkAppTy` n_app tup_ty using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty + poly_arg_ty `mkVisFunTyMany` poly_res_ty -- 'stmts' returns a result of type (m1_ty tuple_ty), -- typically something like [(Int,Bool,Int)] @@ -669,7 +683,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- return :: (a,b,c,..) -> m (a,b,c,..) ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op [synKnownType (mkBigCoreVarTupTy bndr_ids)] - res_ty' $ \ _ -> return () + res_ty' $ \ _ _ -> return () ; return (bndr_ids, by', return_op') } @@ -678,8 +692,8 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; new_res_ty <- newFlexiTyVarTy liftedTypeKind ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op [ synKnownType using_res_ty - , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ] - res_ty $ \ _ -> return () + , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ] + res_ty $ \ _ _ -> return () --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- case form of @@ -687,9 +701,9 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap _ -> fmap unLoc . tcCheckPolyExpr (noLoc fmap_op) $ mkInfForAllTy alphaTyVar $ mkInfForAllTy betaTyVar $ - (alphaTy `mkVisFunTy` betaTy) - `mkVisFunTy` (n_app alphaTy) - `mkVisFunTy` (n_app betaTy) + (alphaTy `mkVisFunTyMany` betaTy) + `mkVisFunTyMany` (n_app alphaTy) + `mkVisFunTyMany` (n_app betaTy) --------------- Typecheck the 'using' function ------------- -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) @@ -699,7 +713,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Building the bindersMap ---------------- ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -752,9 +766,9 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $ (m_ty `mkAppTy` alphaTy) - `mkVisFunTy` + `mkVisFunTyMany` (m_ty `mkAppTy` betaTy) - `mkVisFunTy` + `mkVisFunTyMany` (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLoc mzip_op) mzip_ty @@ -770,7 +784,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside <- tcSyntaxOp MCompOrigin bind_op [ synKnownType (m_ty `mkAppTy` tuple_ty) , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ - \ [inner_res_ty] -> + \ [inner_res_ty] _ -> do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) tup_tys bndr_stmts_s ; return (stuff, inner_res_ty) } @@ -800,7 +814,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op [synKnownType tup_ty] m_tup_ty' $ - \ _ -> return () + \ _ _ -> return () ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs ; return (ids, return_op', pairs', thing) } ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } @@ -824,17 +838,17 @@ tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside = do { -- Deal with rebindable syntax: - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + -- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty -- This level of generality is needed for using do-notation -- in full generality; see #1537 - ((rhs', pat', new_res_ty, thing), bind_op') + ((rhs', pat_mult, pat', new_res_ty, thing), bind_op') <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcCheckMonoExprNC rhs rhs_ty - ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] -> + do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', new_res_ty, thing) } + ; return (rhs', pat_mult, pat', new_res_ty, thing) } -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail -> @@ -842,6 +856,7 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside ; let xbstc = XBindStmtTc { xbstc_bindOp = bind_op' , xbstc_boundResultType = new_res_ty + , xbstc_boundResultMult = pat_mult , xbstc_failOp = fail_op' } ; return (BindStmt xbstc pat' rhs', thing) } @@ -854,7 +869,7 @@ tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside Just join_op -> second Just <$> (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ - \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) + \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } @@ -863,9 +878,9 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside -- (>>) :: rhs_ty -> new_res_ty -> res_ty ; ((rhs', rhs_ty, thing), then_op') <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { rhs' <- tcCheckMonoExprNC rhs rhs_ty - ; thing <- thing_inside (mkCheckExpType new_res_ty) + \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] -> + do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty + ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) ; return (rhs', rhs_ty, thing) } ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } @@ -875,7 +890,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys + -- Many because it's a recursive definition tup_ty = mkBigCoreTupTy tup_elt_tys ; tcExtendIdEnv tup_ids $ do @@ -888,21 +904,21 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names -- be polymorphic) with those of "knot-tied" Ids ; (_, ret_op') <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] - inner_res_ty $ \_ -> return () + inner_res_ty $ \_ _ -> return () ; return (ret_op', tup_rets) } ; ((_, mfix_op'), mfix_res_ty) <- tcInfer $ \ exp_ty -> tcSyntaxOp DoOrigin mfix_op - [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $ - \ _ -> return () + [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ + \ _ _ -> return () ; ((thing, new_res_ty), bind_op') <- tcSyntaxOp DoOrigin bind_op [ synKnownType mfix_res_ty - , synKnownType tup_ty `SynFun` SynRho ] + , SynFun (synKnownType tup_ty) SynRho ] res_ty $ - \ [new_res_ty] -> + \ [new_res_ty] _ -> do { thing <- thing_inside (mkCheckExpType new_res_ty) ; return (thing, new_res_ty) } @@ -949,7 +965,7 @@ tcMonadFailOp orig pat fail_op res_ty = return Nothing | otherwise = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ -> return ()) + (mkCheckExpType res_ty) $ \_ _ -> return ()) {- Note [Treat rebindable syntax first] @@ -993,7 +1009,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ; ts <- replicateM (arity-1) $ newInferExpType ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; let fun_ty = mkVisFunTys pat_tys body_ty + ; let fun_ty = mkVisFunTysMany pat_tys body_ty -- NB. do the <$>,<*> operators first, we don't want type errors here -- i.e. goOps before goArgs @@ -1018,7 +1034,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { (_, op') <- tcSyntaxOp DoOrigin op [synKnownType t_left, synKnownType exp_ty] t_i $ - \ _ -> return () + \ _ _ -> return () ; t_i <- readExpType t_i ; ops' <- goOps t_i ops ; return (op' : ops') } @@ -1035,7 +1051,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ do { rhs' <- tcCheckMonoExprNC rhs exp_ty - ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ return () ; fail_op' <- fmap join . forM fail_op $ \fail -> tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty @@ -1052,7 +1068,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ \res_ty -> do { ret' <- tcExpr ret res_ty - ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ return () ; return (ret', pat') } diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 830f04a89d..9cbfce243a 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -41,6 +41,7 @@ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader +import GHC.Core.Multiplicity import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Validity( arityErr ) @@ -77,7 +78,7 @@ import GHC.Data.List.SetOps ( getNth ) tcLetPat :: (Name -> Maybe TcId) -> LetBndrSpec - -> LPat GhcRn -> ExpSigmaType + -> LPat GhcRn -> Scaled ExpSigmaType -> TcM a -> TcM (LPat GhcTcId, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside @@ -94,7 +95,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside ----------------- tcPats :: HsMatchContext GhcRn -> [LPat GhcRn] -- Patterns, - -> [ExpSigmaType] -- and their types + -> [Scaled ExpSigmaType] -- and their types -> TcM a -- and the checker for the body -> TcM ([LPat GhcTcId], a) @@ -119,12 +120,12 @@ tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn -> TcM ((LPat GhcTcId, a), TcSigmaType) tcInferPat ctxt pat thing_inside = tcInfer $ \ exp_ty -> - tc_lpat exp_ty penv pat thing_inside + tc_lpat (unrestricted exp_ty) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } tcCheckPat :: HsMatchContext GhcRn - -> LPat GhcRn -> TcSigmaType + -> LPat GhcRn -> Scaled TcSigmaType -> TcM a -- Checker for body -> TcM (LPat GhcTcId, a) tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin @@ -132,11 +133,11 @@ tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin -- | A variant of 'tcPat' that takes a custom origin tcCheckPat_O :: HsMatchContext GhcRn -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat GhcRn -> TcSigmaType + -> LPat GhcRn -> Scaled TcSigmaType -> TcM a -- Checker for body -> TcM (LPat GhcTcId, a) -tcCheckPat_O ctxt orig pat pat_ty thing_inside - = tc_lpat (mkCheckExpType pat_ty) penv pat thing_inside +tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside + = tc_lpat (Scaled pat_mult (mkCheckExpType pat_ty)) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } @@ -198,7 +199,7 @@ inPatBind (PE { pe_ctxt = LamPat {} }) = False * * ********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId) +tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaType -> TcM (HsWrapper, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- @@ -210,34 +211,36 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind | Just bndr_id <- sig_fn bndr_name -- There is a signature - = do { wrap <- tc_sub_type penv exp_pat_ty (idType bndr_id) + = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id) -- See Note [Subsumption check at pattern variables] ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) ; return (wrap, bndr_id) } | otherwise -- No signature - = do { (co, bndr_ty) <- case exp_pat_ty of + = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of Check pat_ty -> promoteTcType bind_lvl pat_ty Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) -- If we were under a constructor that bumped -- the level, we'd be in checking mode do { bndr_ty <- inferResultToType infer_res ; return (mkTcNomReflCo bndr_ty, bndr_ty) } - ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty + ; let bndr_mult = scaledMult exp_pat_ty + ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult bndr_ty ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl , ppr exp_pat_ty, ppr bndr_ty, ppr co , ppr bndr_id ]) ; return (mkWpCastN co, bndr_id) } tcPatBndr _ bndr_name pat_ty - = do { pat_ty <- expTypeToType pat_ty + = do { let pat_mult = scaledMult pat_ty + ; pat_ty <- expTypeToType (scaledThing pat_ty) ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) - ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) } + ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_mult pat_ty) } -- We should not have "OrCoVar" here, this is a bug (#17545) -- Whether or not there is a sig is irrelevant, -- as this is local -newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId +newLetBndr :: LetBndrSpec -> Name -> Mult -> TcType -> TcM TcId -- Make up a suitable Id for the pattern-binder. -- See Note [Typechecking pattern bindings], item (4) in GHC.Tc.Gen.Bind -- @@ -248,11 +251,11 @@ newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId -- In the monomorphic case when we are not going to generalise -- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, -- and we use the original name directly -newLetBndr LetLclBndr name ty +newLetBndr LetLclBndr name w ty = do { mono_name <- cloneLocalName name - ; return (mkLocalId mono_name ty) } -newLetBndr (LetGblBndr prags) name ty - = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) + ; return (mkLocalId mono_name w ty) } +newLetBndr (LetGblBndr prags) name w ty + = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name) tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper -- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt @@ -322,7 +325,7 @@ tcMultiple tc_pat penv args thing_inside ; loop penv args } -------------------- -tc_lpat :: ExpSigmaType +tc_lpat :: Scaled ExpSigmaType -> Checker (LPat GhcRn) (LPat GhcTcId) tc_lpat pat_ty penv (L span pat) thing_inside = setSrcSpan span $ @@ -330,7 +333,7 @@ tc_lpat pat_ty penv (L span pat) thing_inside thing_inside ; return (L span pat', res) } -tc_lpats :: [ExpSigmaType] +tc_lpats :: [Scaled ExpSigmaType] -> Checker [LPat GhcRn] [LPat GhcTcId] tc_lpats tys penv pats = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) @@ -339,17 +342,24 @@ tc_lpats tys penv pats (zipEqual "tc_lpats" pats tys) -------------------- -tc_pat :: ExpSigmaType +-- See Note [tcSubMult's wrapper] in TcUnify. +checkManyPattern :: Scaled a -> TcM HsWrapper +checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) + +tc_pat :: Scaled ExpSigmaType -- ^ Fully refined result type -> Checker (Pat GhcRn) (Pat GhcTcId) -- ^ Translated pattern + tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of VarPat x (L l name) -> do { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcExtendIdEnv1 name id thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } + ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $ + tcExtendIdEnv1 name id thing_inside + -- See Note [tcSubMult's wrapper] in TcUnify. + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } ParPat x pat -> do { (pat', res) <- tc_lpat pat_ty penv pat thing_inside @@ -360,7 +370,9 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of ; return (BangPat x pat', res) } LazyPat x pat -> do - { (pat', (res, pat_ct)) + { mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + ; (pat', (res, pat_ct)) <- tc_lpat pat_ty (makeLazy penv) pat $ captureConstraints thing_inside -- Ignore refined penv', revert to penv @@ -370,20 +382,24 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- see Note [Hopping the LIE in lazy patterns] -- Check that the expected pattern type is itself lifted - ; pat_ty <- readExpType pat_ty + ; pat_ty <- readExpType (scaledThing pat_ty) ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind - ; return (LazyPat x pat', res) } + ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) } WildPat _ -> do - { res <- thing_inside - ; pat_ty <- expTypeToType pat_ty - ; return (WildPat pat_ty, res) } + { mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + ; res <- thing_inside + ; pat_ty <- expTypeToType (scaledThing pat_ty) + ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } AsPat x (L nm_loc name) pat -> do - { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + { mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat (mkCheckExpType $ idType bndr_id) + tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) penv pat thing_inside -- NB: if we do inference on: -- \ (y@(x::forall a. a->a)) = e @@ -392,35 +408,43 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- perhaps be fixed, but only with a bit more work. -- -- If you fix it, don't forget the bindInstsOfPatIds! - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, - res) } + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } ViewPat _ expr pat -> do - { (expr',expr_ty) <- tcInferRho expr + { mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + -- + -- It should be possible to have view patterns at linear (or otherwise + -- non-Many) multiplicity. But it is not clear at the moment what + -- restriction need to be put in place, if any, for linear view + -- patterns to desugar to type-correct Core. + + ; (expr',expr_ty) <- tcInferRho expr -- Note [View patterns and polymorphism] -- Expression must be a function ; let expr_orig = lexprCtOrigin expr herald = text "A view pattern expression expects" - ; (expr_wrap1, inf_arg_ty, inf_res_sigma) + ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) <- matchActualFunTySigma herald expr_orig (Just (unLoc expr)) (1,[]) expr_ty -- See Note [View patterns and polymorphism] -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) -- Check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tc_sub_type penv pat_ty inf_arg_ty + ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty -- expr_wrap2 :: pat_ty "->" inf_arg_ty -- Pattern must have inf_res_sigma - ; (pat', res) <- tc_lpat (mkCheckExpType inf_res_sigma) penv pat thing_inside + ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside - ; pat_ty <- readExpType pat_ty + ; let Scaled w h_pat_ty = pat_ty + ; pat_ty <- readExpType h_pat_ty ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - pat_ty inf_res_sigma doc + (Scaled w pat_ty) inf_res_sigma doc -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" -- (pat_ty -> inf_res_sigma) - expr_wrap = expr_wrap2' <.> expr_wrap1 + expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap doc = text "When checking the view pattern function:" <+> (ppr expr) ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)} @@ -446,35 +470,35 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- See Note [Pattern coercions] below SigPat _ pat sig_ty -> do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) - sig_ty pat_ty + sig_ty (scaledThing pat_ty) -- Using tcExtendNameTyVarEnv is appropriate here -- because we're not really bringing fresh tyvars into scope. -- We're *naming* existing tyvars. Note that it is OK for a tyvar -- from an outer scope to mention one of these tyvars in its kind. ; (pat', res) <- tcExtendNameTyVarEnv wcs $ tcExtendNameTyVarEnv tv_binds $ - tc_lpat (mkCheckExpType inner_ty) penv pat thing_inside - ; pat_ty <- readExpType pat_ty + tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside + ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } ------------------------ -- Lists, tuples, arrays ListPat Nothing pats -> do - { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty) + { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty) + ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) penv pats thing_inside - ; pat_ty <- readExpType pat_ty + ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) } ListPat (Just e) pats -> do - { tau_pat_ty <- expTypeToType pat_ty + { tau_pat_ty <- expTypeToType (scaledThing pat_ty) ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] SynList $ - \ [elt_ty] -> - do { (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty) + \ [elt_ty] _ -> + do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty)) penv pats thing_inside ; return (pats', res, elt_ty) } ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) @@ -486,12 +510,12 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- NB: tupleTyCon does not flatten 1-tuples -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty + penv (scaledThing pat_ty) -- Unboxed tuples have RuntimeRep vars, which we discard: -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys - ; (pats', res) <- tc_lpats (map mkCheckExpType con_arg_tys) + ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys) penv pats thing_inside ; dflags <- getDynFlags @@ -508,7 +532,7 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) | otherwise = unmangled_result - ; pat_ty <- readExpType pat_ty + ; pat_ty <- readExpType (scaledThing pat_ty) ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } @@ -516,12 +540,12 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. SumPat _ pat alt arity -> do { let tc = sumTyCon arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty + penv (scaledThing pat_ty) ; -- Drop levity vars, we don't care about them here let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1))) penv pat thing_inside - ; pat_ty <- readExpType pat_ty + ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty , res) } @@ -535,9 +559,9 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- Literal patterns LitPat x simple_lit -> do { let lit_ty = hsLitType simple_lit - ; wrap <- tc_sub_type penv pat_ty lit_ty + ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty ; res <- thing_inside - ; pat_ty <- readExpType pat_ty + ; pat_ty <- readExpType (scaledThing pat_ty) ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty , res) } @@ -560,11 +584,16 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- -- When there is no negation, neg_lit_ty and lit_ty are the same NPat _ (L l over_lit) mb_neg eq -> do - { let orig = LiteralOrigin over_lit + { mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + -- + -- It may be possible to refine linear pattern so that they work in + -- linear environments. But it is not clear how useful this is. + ; let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') - <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] + <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny] (mkCheckExpType boolTy) $ - \ [neg_lit_ty] -> + \ [neg_lit_ty] _ -> let new_over_lit lit_ty = newOverloadedLit over_lit (mkCheckExpType lit_ty) in case mb_neg of @@ -573,11 +602,14 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- The 'negate' is re-mappable syntax second Just <$> (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ - \ [lit_ty] -> new_over_lit lit_ty) + \ [lit_ty] _ -> new_over_lit lit_ty) + -- applied to a closed literal: linearity doesn't matter as + -- literals are typed in an empty environment, hence have + -- all multiplicities. ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat mult_wrap (NPat pat_ty (L l lit') mb_neg' eq') pat_ty, res) } {- Note [NPlusK patterns] @@ -610,19 +642,21 @@ AST is used for the subtraction operation. -- See Note [NPlusK patterns] NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus -> do - { pat_ty <- expTypeToType pat_ty + { mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + ; pat_ty <- expTypeToType (scaledThing pat_ty) ; let orig = LiteralOrigin lit ; (lit1', ge') <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] (mkCheckExpType boolTy) $ - \ [lit1_ty] -> + \ [lit1_ty] _ -> newOverloadedLit lit (mkCheckExpType lit1_ty) ; ((lit2', minus_wrap, bndr_id), minus') <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ - \ [lit2_ty, var_ty] -> + \ [lit2_ty, var_ty] _ -> do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) ; (wrap, bndr_id) <- setSrcSpan nm_loc $ - tcPatBndr penv name (mkCheckExpType var_ty) + tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) -- co :: var_ty ~ idType bndr_id -- minus_wrap is applicable to minus' @@ -650,7 +684,7 @@ AST is used for the subtraction operation. -- we get warnings if we try. #17783 pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' - ; return (pat', res) } + ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) } -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. -- Here we get rid of it and add the finalizers to the global environment. @@ -813,7 +847,7 @@ to express the local scope of GADT refinements. -- with scrutinee of type (T ty) tcConPat :: PatEnv -> Located Name - -> ExpSigmaType -- Type of the pattern + -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside @@ -826,10 +860,10 @@ tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside } tcDataConPat :: PatEnv -> Located Name -> DataCon - -> ExpSigmaType -- Type of the pattern + -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcDataConPat penv (L con_span con_name) data_con pat_ty +tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon @@ -840,13 +874,13 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion, -- and building a wrapper - ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty - ; pat_ty <- readExpType pat_ty + ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty_scaled + ; pat_ty <- readExpType (scaledThing pat_ty_scaled) -- Add the stupid theta ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys + ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) ; checkExistentials ex_tvs all_arg_tys penv ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys @@ -861,7 +895,9 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty -- pat_ty' is type of the actual constructor application -- pat_ty' /= pat_ty iff coi /= IdCo - arg_tys' = substTys tenv arg_tys + arg_tys' = substScaledTys tenv arg_tys + pat_mult = scaledMult pat_ty_scaled + arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' ; traceTc "tcConPat" (vcat [ ppr con_name , pprTyVars univ_tvs @@ -875,7 +911,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' + (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys_scaled penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header , pat_args = arg_pats' @@ -912,7 +948,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys' penv arg_pats thing_inside + tcConArgs (RealDataCon data_con) arg_tys_scaled penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header @@ -929,7 +965,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty } } tcPatSynPat :: PatEnv -> Located Name -> PatSyn - -> ExpSigmaType -- Type of the pattern + -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside @@ -937,15 +973,20 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside ; (subst, univ_tvs') <- newMetaTyVars univ_tvs - ; let all_arg_tys = ty : prov_theta ++ arg_tys + ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) ; checkExistentials ex_tvs all_arg_tys penv ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs ; let ty' = substTy tenv ty - arg_tys' = substTys tenv arg_tys + arg_tys' = substScaledTys tenv arg_tys + pat_mult = scaledMult pat_ty + arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' prov_theta' = substTheta tenv prov_theta req_theta' = substTheta tenv req_theta - ; wrap <- tc_sub_type penv pat_ty ty' + ; mult_wrap <- checkManyPattern pat_ty + -- See Note [tcSubMult's wrapper] in TcUnify. + + ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' ; traceTc "tcPatSynPat" (ppr pat_syn $$ ppr pat_ty $$ ppr ty' $$ @@ -966,7 +1007,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside ; traceTc "checkConstraints {" Outputable.empty ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys' penv arg_pats thing_inside + tcConArgs (PatSynCon pat_syn) arg_tys_scaled penv arg_pats thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn @@ -979,8 +1020,8 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside , cpt_wrap = req_wrap } } - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + ; pat_ty <- readExpType (scaledThing pat_ty) + ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function @@ -1001,9 +1042,9 @@ matchExpectedConTy :: PatEnv -- constructor actually returns -- In the case of a data family this is -- the /representation/ TyCon - -> ExpSigmaType -- The type of the pattern; in the case - -- of a data family this would mention - -- the /family/ TyCon + -> Scaled ExpSigmaType -- The type of the pattern; in the + -- case of a data family this would + -- mention the /family/ TyCon -> TcM (HsWrapper, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a wrapper : pat_ty "->" T ty1 ... tyn @@ -1011,7 +1052,7 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc -- Comments refer to Note [Matching constructor patterns] -- co_tc :: forall a. T [a] ~ T7 a - = do { pat_ty <- expTypeToType exp_pat_ty + = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) @@ -1038,7 +1079,7 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty ; return ( mkWpCastR full_co <.> wrap, tys') } | otherwise - = do { pat_ty <- expTypeToType exp_pat_ty + = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } @@ -1072,7 +1113,7 @@ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty error messages; it's a purely internal thing -} -tcConArgs :: ConLike -> [TcSigmaType] +tcConArgs :: ConLike -> [Scaled TcSigmaType] -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of @@ -1114,7 +1155,7 @@ tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of pun), res) } - find_field_ty :: Name -> FieldLabelString -> TcM TcType + find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType) find_field_ty sel lbl = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of @@ -1131,14 +1172,15 @@ tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of traceTc "find_field" (ppr pat_ty <+> ppr extras) ASSERT( null extras ) (return pat_ty) - field_tys :: [(FieldLabel, TcType)] + field_tys :: [(FieldLabel, Scaled TcType)] field_tys = zip (conLikeFieldLabels con_like) arg_tys -- Don't use zipEqual! If the constructor isn't really a record, then -- dataConFieldLabels will be empty (and each field in the pattern -- will generate an error below). -tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) -tcConArg penv (arg_pat, arg_ty) = tc_lpat (mkCheckExpType arg_ty) penv arg_pat +tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc) +tcConArg penv (arg_pat, Scaled arg_mult arg_ty) + = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 7475b2e737..49de48cebd 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -28,6 +28,7 @@ import GHC.Tc.Utils.Unify( buildImplicationFor ) import GHC.Tc.Types.Evidence( mkTcCoVarCo ) import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) +import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Types.Var( EvVar ) import GHC.Types.Var.Set @@ -221,7 +222,7 @@ tcRuleTmBndrs [] = return ([],[]) tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs - ; return (tyvars, mkLocalId name ty : tmvars) } + ; return (tyvars, mkLocalId name Many ty : tmvars) } tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written @@ -230,7 +231,7 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- error for each out-of-scope type variable used = do { let ctxt = RuleSigCtxt name ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalId name id_ty + ; let id = mkLocalId name Many id_ty -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType -- The type variables scope over subsequent bindings; yuk diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index df0c7d37f6..89fcff3079 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -40,6 +40,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) import GHC.Core.Type ( mkTyVarBinders ) +import GHC.Core.Multiplicity import GHC.Driver.Session import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) @@ -224,7 +225,12 @@ tcUserTypeSig loc hs_sig_ty mb_name = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty ; traceTc "tcuser" (ppr sigma_ty) ; return $ - CompleteSig { sig_bndr = mkLocalId name sigma_ty + CompleteSig { sig_bndr = mkLocalId name Many sigma_ty + -- We use `Many' as the multiplicity here, + -- as if this identifier corresponds to + -- anything, it is a top-level + -- definition. Which are all unrestricted in + -- the current implementation. , sig_ctxt = ctxt_T , sig_loc = loc } } -- Location of the <type> in f :: <type> @@ -266,7 +272,7 @@ no_anon_wc lty = go lty HsWildCardTy _ -> False HsAppTy _ ty1 ty2 -> go ty1 && go ty2 HsAppKindTy _ ty ki -> go ty && go ki - HsFunTy _ ty1 ty2 -> go ty1 && go ty2 + HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys HsSumTy _ tys -> gos tys @@ -436,7 +442,7 @@ tcPatSynSig name sig_ty -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here ; let (arg_tys, _) = tcSplitFunTys body_ty' - ; mapM_ (checkForLevPoly empty) arg_tys + ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys ; traceTc "tcTySig }" $ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 140299997a..5d0db81183 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -44,6 +44,7 @@ import GHC.Driver.Finder import GHC.Types.Name import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity import GHC.Utils.Outputable import GHC.Tc.Gen.Expr @@ -238,7 +239,7 @@ tcUntypedBracket rn_expr brack ps res_ty -- | A type variable with kind * -> * named "m" mkMetaTyVar :: TcM TyVar mkMetaTyVar = - newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind) + newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind) -- | For a type 'm', emit the constraint 'Quote m'. @@ -1757,7 +1758,7 @@ reifyDataCon isGadtDataCon tys dc filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' g_theta = substTys tvb_subst g_theta' - g_arg_tys = substTys tvb_subst g_arg_tys' + g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys') g_res_ty = substTy tvb_subst g_res_ty' ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) @@ -2115,9 +2116,14 @@ reifyType ty@(AppTy {}) = do filter_out_invisible_args ty_head ty_args = filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args -reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) +reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 }) | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] + ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) + | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty) + | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] + ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) @@ -2145,7 +2151,7 @@ reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType reifyPatSynType - :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type) -> TcM TH.Type + :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type -- reifies a pattern synonym's type and returns its *complete* type -- signature; see NOTE [Pattern synonym signatures and Template -- Haskell] @@ -2213,7 +2219,7 @@ reify_tc_app tc tys else TH.TupleT arity | tc `hasKey` constraintKindTyConKey = TH.ConstraintT - | tc `hasKey` funTyConKey = TH.ArrowT + | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT | tc `hasKey` listTyConKey = TH.ListT | tc `hasKey` nilDataConKey = TH.PromotedNilT | tc `hasKey` consDataConKey = TH.PromotedConsT diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index aec5c85e20..642e303442 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -32,6 +32,7 @@ import GHC.Builtin.Names import GHC.Types.Id import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) import GHC.Types.Name ( Name, pprDefinedAt ) @@ -430,15 +431,15 @@ matchTypeable clas [k,t] -- clas = Typeable matchTypeable _ _ = return NoInstance -- | Representation for a type @ty@ of the form @arg -> ret@. -doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult -doFunTy clas ty arg_ty ret_ty +doFunTy :: Class -> Type -> Scaled Type -> Type -> TcM ClsInstResult +doFunTy clas ty (Scaled mult arg_ty) ret_ty = return $ OneInst { cir_new_theta = preds , cir_mk_ev = mk_ev , cir_what = BuiltinInstance } where - preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] - mk_ev [arg_ev, ret_ev] = evTypeable ty $ - EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev) + preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty] + mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $ + EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy" @@ -685,7 +686,7 @@ matchHasField dflags short_cut clas tys -- the HasField x r a dictionary. The preds will -- typically be empty, but if the datatype has a -- "stupid theta" then we have to include it here. - ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds + ; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds -- Use the equality proof to cast the selector Id to -- type (r -> a), then use the newtype coercion to cast diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index 3f8b7d8281..a7b3d83e09 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -34,6 +34,7 @@ import GHC.Types.Id import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.DataCon +import GHC.Core.Multiplicity import GHC.Unit.Module import GHC.Hs import GHC.Driver.Session @@ -437,7 +438,9 @@ kindIsTypeable ty | isLiftedTypeKind ty = True kindIsTypeable (TyVarTy _) = True kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (FunTy _ a b) = kindIsTypeable a && kindIsTypeable b +kindIsTypeable (FunTy _ w a b) = kindIsTypeable w && + kindIsTypeable a && + kindIsTypeable b kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc && all kindIsTypeable args kindIsTypeable (ForAllTy{}) = False @@ -466,8 +469,8 @@ liftTc = KindRepM . lift builtInKindReps :: [(Kind, Name)] builtInKindReps = [ (star, starKindRepName) - , (mkVisFunTy star star, starArrStarKindRepName) - , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName) + , (mkVisFunTyMany star star, starArrStarKindRepName) + , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) ] where star = liftedTypeKind @@ -537,7 +540,7 @@ getKindRep stuff@(Stuff {..}) in_scope = go = do -- Place a NOINLINE pragma on KindReps since they tend to be quite -- large and bloat interface files. rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon) + <$> newSysLocalId (fsLit "$krep") Many (mkTyConTy kindRepTyCon) -- do we need to tie a knot here? flip runStateT env $ unKindRepM $ do @@ -591,7 +594,7 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep new_kind_rep (ForAllTy (Bndr var _) ty) = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) - new_kind_rep (FunTy _ t1 t2) + new_kind_rep (FunTy _ _ t1 t2) = do rep1 <- getKindRep stuff in_scope t1 rep2 <- getKindRep stuff in_scope t2 return $ nlHsDataCon kindRepFunDataCon diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index f6e5b87f53..5ef192befe 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -1274,7 +1274,7 @@ checkBootTyCon is_boot tc1 tc2 check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) (text "The record label lists for" <+> pname1 <+> text "differ") `andThenCheck` - check (eqType (dataConUserType c1) (dataConUserType c2)) + check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) (text "The types for" <+> pname1 <+> text "differ") where name1 = dataConName c1 @@ -2446,7 +2446,7 @@ getGhciStepIO = do { hst_tele = mkHsForAllInvisTele [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)] , hst_xforall = noExtField - , hst_body = nlHsFunTy ghciM ioM } + , hst_body = nlHsFunTy HsUnrestrictedArrow ghciM ioM } stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) @@ -2965,7 +2965,8 @@ ppr_datacons debug type_env = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs -- The filter gets rid of class data constructors where - ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc) + ppr_dc dc = sdocWithDynFlags (\dflags -> + ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc)) all_dcs = typeEnvDataCons type_env wanted_dcs | debug = all_dcs | otherwise = filterOut is_cls_dc all_dcs diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 61477af714..8754ef9fd0 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -50,7 +50,7 @@ import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type -import GHC.Builtin.Types ( liftedRepTy ) +import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Types.Var @@ -2223,6 +2223,13 @@ defaultTyVarTcS the_tv = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) ; unifyTyVar the_tv liftedRepTy ; return True } + | isMultiplicityVar the_tv + , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. TcMType.defaultTyVar + -- See Note [Kind generalisation and SigTvs] + = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) + ; unifyTyVar the_tv manyDataConTy + ; return True } | otherwise = return False -- the common case diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 2fc8664450..79b42d29d5 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -25,6 +25,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Core.Class import GHC.Core.TyCon +import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core @@ -551,7 +552,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) (sc_theta, sc_inner_pred) = splitFunTys sc_rho all_tvs = tvs `chkAppend` sc_tvs - all_theta = theta `chkAppend` sc_theta + all_theta = theta `chkAppend` (map scaledThing sc_theta) swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred -- evar :: forall tvs. theta => cls tys @@ -1007,16 +1008,16 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ -- Decompose FunTy: (s -> t) and (c => t) -- NB: don't decompose (Int -> blah) ~ (Show a => blah) can_eq_nc' _flat _rdr_env _envs ev eq_rel - (FunTy { ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ - (FunTy { ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ + (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ + (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ | af1 == af2 -- Don't decompose (Int -> blah) ~ (Show a => blah) , Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe: , Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy] , Just ty2a_rep <- getRuntimeRep_maybe ty2a , Just ty2b_rep <- getRuntimeRep_maybe ty2b = canDecomposableTyConAppOK ev eq_rel funTyCon - [ty1a_rep, ty1b_rep, ty1a, ty1b] - [ty2a_rep, ty2b_rep, ty2a, ty2b] + [am1, ty1a_rep, ty1b_rep, ty1a, ty1b] + [am2, ty2a_rep, ty2b_rep, ty2a, ty2b] -- Decompose type constructor applications -- NB: e have expanded type synonyms already @@ -1177,11 +1178,12 @@ zonk_eq_types = go -- RuntimeReps of the argument and result types. This can be observed in -- testcase tc269. go ty1 ty2 - | Just (arg1, res1) <- split1 - , Just (arg2, res2) <- split2 + | Just (Scaled w1 arg1, res1) <- split1 + , Just (Scaled w2 arg2, res2) <- split2 + , eqType w1 w2 = do { res_a <- go arg1 arg2 ; res_b <- go res1 res2 - ; return $ combine_rev mkVisFunTy res_b res_a + ; return $ combine_rev (mkVisFunTy w1) res_b res_a } | isJust split1 || isJust split2 = bale_out ty1 ty2 @@ -2469,10 +2471,11 @@ unifyWanted loc role orig_ty1 orig_ty2 go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - go (FunTy _ s1 t1) (FunTy _ s2 t2) + go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) = do { co_s <- unifyWanted loc role s1 s2 ; co_t <- unifyWanted loc role t1 t2 - ; return (mkFunCo role co_s co_t) } + ; co_w <- unifyWanted loc Nominal w1 w2 + ; return (mkFunCo role co_w co_s co_t) } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality @@ -2520,9 +2523,10 @@ unify_derived loc role orig_ty1 orig_ty2 go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - go (FunTy _ s1 t1) (FunTy _ s2 t2) + go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) = do { unify_derived loc role s1 s2 - ; unify_derived loc role t1 t2 } + ; unify_derived loc role t1 t2 + ; unify_derived loc role w1 w2 } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs index 6916357691..48249caa5c 100644 --- a/compiler/GHC/Tc/Solver/Flatten.hs +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -39,6 +39,8 @@ import Data.Foldable ( foldrM ) import Control.Arrow ( first ) +import GHC.Core.Multiplicity + {- Note [The flattening story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1175,12 +1177,13 @@ flatten_one (TyConApp tc tys) -- _ -> fmode = flatten_ty_con_app tc tys -flatten_one ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) +flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) = do { (xi1,co1) <- flatten_one ty1 ; (xi2,co2) <- flatten_one ty2 + ; (xi3,co3) <- flatten_one mult ; role <- getRole - ; return (ty { ft_arg = xi1, ft_res = xi2 } - , mkFunCo role co1 co2) } + ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 } + , mkFunCo role co3 co1 co2) } flatten_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't flatten the kind of @@ -1921,9 +1924,9 @@ split_pi_tys' ty = split ty ty split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' split _ (ForAllTy b res) = let (bs, ty, _) = split res res in (Named b : bs, ty, True) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) = let (bs, ty, named) = split res res - in (Anon af arg : bs, ty, named) + in (Anon af (mkScaled w arg) : bs, ty, named) split orig_ty _ = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} @@ -1935,6 +1938,6 @@ ty_con_binders_ty_binders' = foldr go ([], False) go (Bndr tv (NamedTCB vis)) (bndrs, _) = (Named (Bndr tv vis) : bndrs, True) go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (tyVarKind tv) : bndrs, n) + = (Anon af (unrestricted (tyVarKind tv)) : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 6af35c77c2..a4a56c0a14 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -44,6 +44,7 @@ import GHC.Tc.Instance.Class( AssocInstInfo(..) ) import GHC.Tc.Utils.TcMType import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon ) import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity import GHC.Rename.Env( lookupConstructorFields ) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv @@ -823,9 +824,9 @@ swizzleTcTyConBndrs tc_infos swizzle_var :: Var -> Var swizzle_var v | Just nm <- lookupVarEnv swizzle_env v - = updateVarType swizzle_ty (v `setVarName` nm) + = updateVarTypeAndMult swizzle_ty (v `setVarName` nm) | otherwise - = updateVarType swizzle_ty v + = updateVarTypeAndMult swizzle_ty v (map_type, _, _, _) = mapTyCo swizzleMapper swizzle_ty ty = runIdentity (map_type ty) @@ -1561,10 +1562,10 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () +kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do { let exp_kind = getArgExpKind new_or_data res_kind - ; mapM_ (flip tcCheckLHsType exp_kind . getBangType) arg_tys + ; mapM_ (flip tcCheckLHsType exp_kind . getBangType . hsScaledThing) arg_tys -- See Note [Implementation of UnliftedNewtypes], STEP 2 } @@ -3134,7 +3135,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data ; (ze, qkvs) <- zonkTyBndrs kvs ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs ; let user_qtvs = binderVars user_qtvbndrs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt ; fam_envs <- tcGetFamInstEnvs @@ -3216,7 +3217,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- Zonk to Types ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt ; res_ty <- zonkTcTypeToTypeX ze res_ty @@ -3225,7 +3226,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- See Note [Checking GADT return types] ctxt' = substTys arg_subst ctxt - arg_tys' = substTys arg_subst arg_tys + arg_tys' = substScaledTys arg_subst arg_tys res_ty' = substTy arg_subst res_ty @@ -3262,7 +3263,7 @@ getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _ = OpenKind tcConIsInfixH98 :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) + -> HsConDetails a b -> TcM Bool tcConIsInfixH98 _ details = case details of @@ -3270,7 +3271,7 @@ tcConIsInfixH98 _ details _ -> return False tcConIsInfixGADT :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) + -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r -> TcM Bool tcConIsInfixGADT con details = case details of @@ -3278,7 +3279,7 @@ tcConIsInfixGADT con details RecCon {} -> return False PrefixCon arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) - , [_ty1,_ty2] <- arg_tys + , [_ty1,_ty2] <- map hsScaledThing arg_tys -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False @@ -3287,7 +3288,7 @@ tcConArgs :: ContextKind -- expected kind of arguments -- always OpenKind for datatypes, but unlifted newtypes -- might have a specific kind -> HsConDeclDetails GhcRn - -> TcM [(TcType, HsSrcBang)] + -> TcM [(Scaled TcType, HsSrcBang)] tcConArgs exp_kind (PrefixCon btys) = mapM (tcConArg exp_kind) btys tcConArgs exp_kind (InfixCon bty1 bty2) @@ -3298,7 +3299,7 @@ tcConArgs exp_kind (RecCon fields) = mapM (tcConArg exp_kind) btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) + combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined @@ -3307,12 +3308,13 @@ tcConArgs exp_kind (RecCon fields) tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, -- but might be an unlifted type with UnliftedNewtypes - -> LHsType GhcRn -> TcM (TcType, HsSrcBang) -tcConArg exp_kind bty + -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang) +tcConArg exp_kind (HsScaled w bty) = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind + ; w' <- tcMult w ; traceTc "tcConArg 2" (ppr bty) - ; return (arg_ty, getBangStrictness bty) } + ; return (Scaled w' arg_ty, getBangStrictness bty) } {- Note [Infix GADT constructors] @@ -3925,10 +3927,10 @@ checkValidDataCon dflags existential_ok tc con ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty)) (badDataConTyCon con res_ty_tmpl) -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConUserType + -- critical to avoid panicking when we call dataConDisplayType -- on an un-rejiggable datacon! - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) + ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) -- Check that the result type is a *monotype* -- e.g. reject this: MkT :: T (forall a. a->a) @@ -3940,7 +3942,7 @@ checkValidDataCon dflags existential_ok tc con -- later check in checkNewDataCon handles this, producing a -- better error message than checkForLevPoly would. ; unless (isNewTyCon tc) - (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) + (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)) -- Extra checks for newtype data constructors. Importantly, these -- checks /must/ come before the call to checkValidType below. This @@ -3950,7 +3952,7 @@ checkValidDataCon dflags existential_ok tc con ; when (isNewTyCon tc) (checkNewDataCon con) -- Check all argument types for validity - ; checkValidType ctxt (dataConUserType con) + ; checkValidType ctxt data_con_display_type -- Check that existentials are allowed if they are used ; checkTc (existential_ok || isVanillaDataCon con) @@ -3980,8 +3982,9 @@ checkValidDataCon dflags existential_ok tc con ; traceTc "Done validity of data con" $ vcat [ ppr con - , text "Datacon user type:" <+> ppr (dataConUserType con) + , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con) , text "Datacon rep type:" <+> ppr (dataConRepType con) + , text "Datacon display type:" <+> ppr data_con_display_type , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) , case tyConFamInst_maybe (dataConTyCon con) of Nothing -> text "not family" @@ -4023,6 +4026,9 @@ checkValidDataCon dflags existential_ok tc con bad_bang n herald = hang herald 2 (text "on the" <+> speakNth n <+> text "argument of" <+> quotes (ppr con)) + + data_con_display_type = dataConDisplayType dflags con + ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype @@ -4032,11 +4038,18 @@ checkNewDataCon con ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType = - unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True + unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True ; checkTc allowedArgType $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ] + ; dflags <- getDynFlags + + ; let check_con what msg = + checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)) + + ; checkTc (ok_mult (scaledMult arg_ty1)) $ + text "A newtype constructor must be linear" ; check_con (null eq_spec) $ text "A newtype constructor must have a return type of form T a1 ... an" @@ -4056,8 +4069,6 @@ checkNewDataCon con where (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con - check_con what msg - = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) (arg_ty1 : _) = arg_tys @@ -4065,6 +4076,9 @@ checkNewDataCon con ok_bang (HsSrcBang _ _ SrcLazy) = False ok_bang _ = True + ok_mult One = True + ok_mult _ = False + ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls @@ -4511,7 +4525,7 @@ checkValidRoles tc check_dc_roles datacon = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ arg_tys } + eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) } -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) @@ -4548,8 +4562,9 @@ checkValidRoles tc = check_ty_roles env role ty1 >> check_ty_roles env Nominal ty2 - check_ty_roles env role (FunTy _ ty1 ty2) - = check_ty_roles env role ty1 + check_ty_roles env role (FunTy _ w ty1 ty2) + = check_ty_roles env role w + >> check_ty_roles env role ty1 >> check_ty_roles env role ty2 check_ty_roles env role (ForAllTy (Bndr tv _) ty) @@ -4719,10 +4734,11 @@ badGadtDecl tc_name badExistential :: DataCon -> SDoc badExistential con - = hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) + = sdocWithDynFlags (\dflags -> + hang (text "Data constructor" <+> quotes (ppr con) <+> + text "has existential type variables, a context, or a specialised result type") + 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con) + , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) badStupidTheta :: Name -> SDoc badStupidTheta tc_name diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index af49e9e28c..5361ff0160 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -36,6 +36,7 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Types.Id import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Driver.Session @@ -65,7 +66,7 @@ mkNewTyConRhs tycon_name tycon con roles = tyConRoles tycon res_kind = tyConResKind tycon con_arg_ty = case dataConRepArgTys con of - [arg_ty] -> arg_ty + [arg_ty] -> scaledThing arg_ty tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) rhs_ty = substTyWith (dataConUnivTyVars con) (mkTyVarTys tvs) con_arg_ty @@ -110,7 +111,7 @@ buildDataCon :: FamInstEnvs -> [EqSpec] -- Equality spec -> KnotTied ThetaType -- Does not include the "stupid theta" -- or the GADT equalities - -> [KnotTied Type] -- Arguments + -> [KnotTied (Scaled Type)] -- Arguments -> KnotTied Type -- Result types -> KnotTied TyCon -- Rep tycon -> NameEnv ConTag -- Maps the Name of each DataCon to its @@ -132,7 +133,7 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs ; traceIf (text "buildDataCon 1" <+> ppr src_name) ; us <- newUniqueSupply ; dflags <- getDynFlags - ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs + ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs tag = lookupNameEnv_NF tag_map src_name -- See Note [Constructor tag allocation], fixes #14657 data_con = mkDataCon src_name declared_infix prom_info @@ -184,10 +185,10 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder -- compatible with the pattern synonym ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 , ex_tvs `equalLength` ex_tvs1 - , pat_ty `eqType` substTy subst pat_ty1 + , pat_ty `eqType` substTy subst (scaledThing pat_ty1) , prov_theta `eqTypes` substTys subst prov_theta1 , req_theta `eqTypes` substTys subst req_theta1 - , compareArgTys arg_tys (substTys subst arg_tys1) + , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1)) ]) , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 @@ -202,7 +203,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder where ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau - (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) (arg_tys1, _) = (tcSplitFunTys cont_tau) twiddle = char '~' subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) @@ -314,7 +315,7 @@ buildClass tycon_name binders roles fds univ_bndrs [{- No GADT equalities -}] [{- No theta -}] - arg_tys + (map unrestricted arg_tys) -- type classes are unrestricted (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) rec_tycon (mkTyConTagMap rec_tycon) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index cedd42916b..c6f78ae4e2 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -40,6 +40,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType import GHC.Core.Type ( piResultTys ) import GHC.Core.Predicate +import GHC.Core.Multiplicity import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad @@ -284,7 +285,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ctxt = FunSigCtxt sel_name warn_redundant - ; let local_dm_id = mkLocalId local_dm_name local_dm_ty + ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty local_dm_sig = CompleteSig { sig_bndr = local_dm_id , sig_ctxt = ctxt , sig_loc = getLoc (hsSigType hs_ty) } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 4c43d91f3e..68bf24c342 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -41,6 +41,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) +import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv @@ -1318,7 +1319,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm ; let sc_top_ty = mkInfForAllTys tyvars $ mkPhiTy (map idType dfun_evs) sc_pred - sc_top_id = mkLocalId sc_top_name sc_top_ty + sc_top_id = mkLocalId sc_top_name Many sc_top_ty export = ABE { abe_ext = noExtField , abe_wrap = idHsWrapper , abe_poly = sc_top_id @@ -1798,7 +1799,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind ; let ctxt = FunSigCtxt sel_name True -- True <=> check for redundant constraints in the -- user-specified instance signature - inner_meth_id = mkLocalId inner_meth_name sig_ty + inner_meth_id = mkLocalId inner_meth_name Many sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt , sig_loc = getLoc (hsSigType hs_sig_ty) } @@ -1849,8 +1850,8 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; local_meth_name <- newName sel_occ -- Base the local_meth_name on the selector name, because -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty + ; let poly_meth_id = mkLocalId poly_meth_name Many poly_meth_ty + local_meth_id = mkLocalId local_meth_name Many local_meth_ty ; return (poly_meth_id, local_meth_id) } where diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 57dd16c8f8..5f99763fdd 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -24,6 +24,7 @@ import GHC.Prelude import GHC.Hs import GHC.Tc.Gen.Pat +import GHC.Core.Multiplicity import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId ) @@ -106,7 +107,7 @@ recoverPSB (PSB { psb_id = L _ name where -- The matcher_id is used only by the desugarer, so actually -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name $ + matcher_id = mkLocalId matcher_name Many $ mkSpecForAllTys [alphaTyVar] alphaTy {- Note [Pattern synonym error recovery] @@ -387,7 +388,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) pushLevelAndCaptureConstraints $ tcExtendTyVarEnv univ_tvs $ - tcCheckPat PatSyn lpat pat_ty $ + tcCheckPat PatSyn lpat (unrestricted pat_ty) $ do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) empty_subst = mkEmptyTCvSubst in_scope ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs @@ -402,7 +403,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- substitution. -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' - ; args' <- zipWithM (tc_arg subst) arg_names arg_tys + ; args' <- zipWithM (tc_arg subst) arg_names (map scaledThing arg_tys) ; return (ex_tvs', prov_dicts, args') } ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] @@ -423,7 +424,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; tc_patsyn_finish lname dir is_infix lpat' (univ_bndrs, req_theta, ev_binds, req_dicts) (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) - (args', arg_tys) + (args', (map scaledThing arg_tys)) pat_ty rec_fields } where tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId) @@ -701,16 +702,16 @@ tcPatSynMatcher (L loc name) lpat | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) | otherwise = (args, arg_tys) cont_ty = mkInfSigmaTy ex_tvs prov_theta $ - mkVisFunTys cont_arg_tys res_ty + mkVisFunTysMany cont_arg_tys res_ty - fail_ty = mkVisFunTy voidPrimTy res_ty + fail_ty = mkVisFunTyMany voidPrimTy res_ty ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty - ; cont <- newSysLocalId (fsLit "cont") cont_ty - ; fail <- newSysLocalId (fsLit "fail") fail_ty + ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty + ; cont <- newSysLocalId (fsLit "cont") Many cont_ty + ; fail <- newSysLocalId (fsLit "fail") Many fail_ty - ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty + ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau matcher_id = mkExportedVanillaId matcher_name matcher_sigma -- See Note [Exported LocalIds] in GHC.Types.Id @@ -730,14 +731,14 @@ tcPatSynMatcher (L loc name) lpat L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = L (getLoc lpat) cases - , mg_ext = MatchGroupTc [pat_ty] res_ty + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty , mg_origin = Generated } body' = noLoc $ HsLam noExtField $ MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr args body] - , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } match = mkMatch (mkPrefixFunRhs (L loc name)) [] @@ -799,7 +800,7 @@ mkPatSynBuilderId dir (L _ name) mkInvisForAllTys univ_bndrs $ mkInvisForAllTys ex_bndrs $ mkPhiTy theta $ - mkVisFunTys arg_tys $ + mkVisFunTysMany arg_tys $ pat_ty builder_id = mkExportedVanillaId builder_name builder_sigma -- See Note [Exported LocalIds] in GHC.Types.Id @@ -905,7 +906,7 @@ tcPatSynBuilderOcc ps add_void :: Bool -> Type -> Type add_void need_dummy_arg ty - | need_dummy_arg = mkVisFunTy voidPrimTy ty + | need_dummy_arg = mkVisFunTyMany voidPrimTy ty | otherwise = ty tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 00a4c01493..b49e81ddd2 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -36,6 +36,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds ) import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) +import GHC.Core.Multiplicity import GHC.Tc.Utils.TcType import GHC.Core.Predicate import GHC.Builtin.Types( unitTy ) @@ -90,7 +91,7 @@ synonymTyConsOfType ty go (LitTy _) = emptyNameEnv go (TyVarTy _) = emptyNameEnv go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy _ a b) = go a `plusNameEnv` go b + go (FunTy _ w a b) = go w `plusNameEnv` go a `plusNameEnv` go b go (ForAllTy _ ty) = go ty go (CastTy ty co) = go ty `plusNameEnv` go_co co go (CoercionTy co) = go_co co @@ -124,7 +125,7 @@ synonymTyConsOfType ty go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co' + go_co (FunCo _ co_mult co co') = go_co co_mult `plusNameEnv` go_co co `plusNameEnv` go_co co' go_co (CoVarCo _) = emptyNameEnv go_co (HoleCo {}) = emptyNameEnv go_co (AxiomInstCo _ _ cs) = go_co_s cs @@ -579,7 +580,7 @@ irDataCon datacon = setRoleInferenceVars univ_tvs $ irExTyVars ex_tvs $ \ ex_var_set -> mapM_ (irType ex_var_set) - (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) + (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys)) -- See Note [Role-checking data constructor arguments] where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) @@ -599,7 +600,7 @@ irType = go lcls' = extendVarSet lcls tv ; markNominal lcls (tyVarKind tv) ; go lcls' ty } - go lcls (FunTy _ arg res) = go lcls arg >> go lcls res + go lcls (FunTy _ w arg res) = go lcls w >> go lcls arg >> go lcls res go _ (LitTy {}) = return () -- See Note [Coercions in role inference] go lcls (CastTy ty _) = go lcls ty @@ -635,7 +636,7 @@ markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in get_ty_vars :: Type -> FV get_ty_vars (TyVarTy tv) = unitFV tv get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (FunTy _ t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2 get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) get_ty_vars (LitTy {}) = emptyFV @@ -881,7 +882,10 @@ mkOneRecordSelector all_cons idDetails fl mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! -- req_theta is empty for normal DataCon mkPhiTy req_theta $ - mkVisFunTy data_ty $ + mkVisFunTyMany data_ty $ + -- Record selectors are always typed with Many. We + -- could improve on it in the case where all the + -- fields in all the constructor have multiplicity Many. field_ty -- Make the binding: sel (C2 { fld = x }) = x diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 2afb6bc234..1397a3da4b 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -95,6 +95,7 @@ import GHC.Core.TyCon ( TyCon, tyConKind ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Types.Id ( idType, idName ) import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Core.UsageEnv import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin @@ -775,6 +776,9 @@ data TcLclEnv -- Changes as we move inside an expression tcl_env :: TcTypeEnv, -- The local type environment: -- Ids and TyVars defined in this module + tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here. + + tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying types diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 8649871670..5b33394136 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -88,6 +88,7 @@ import GHC.Utils.Outputable import GHC.Types.SrcLoc import Data.IORef( IORef ) import GHC.Types.Unique.Set +import GHC.Core.Multiplicity {- Note [TcCoercions] @@ -117,7 +118,7 @@ mkTcNomReflCo :: TcType -> TcCoercionN mkTcRepReflCo :: TcType -> TcCoercionR mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion +mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -> TcCoercion mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [TcType] -> [TcCoercion] -> TcCoercion mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] @@ -201,8 +202,8 @@ data HsWrapper -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) - | WpFun HsWrapper HsWrapper TcType SDoc - -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] + | WpFun HsWrapper HsWrapper (Scaled TcType) SDoc + -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w t1). wrap2[ e wrap1[x] ] -- So note that if wrap1 :: exp_arg <= act_arg -- wrap2 :: act_res <= exp_res -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) @@ -228,6 +229,18 @@ data HsWrapper | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, -- so that the identity coercion is always exactly WpHole + | WpMultCoercion Coercion + -- Note [Checking multiplicity coercions] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- This wrapper can be returned from tcSubMult. + -- It is used in case a variable is used with multiplicity m1, + -- we need it with multiplicity m2 and we have a coercion c :: m1 ~ m2. + -- Compiling such code would require multiplicity coercions in Core, + -- which we don't have. If the desugarer sees WpMultCoercion + -- with a non-reflexive coercion, it gives an error. + -- This is a temporary measure, as we don't really know yet exactly + -- what multiplicity coercions should be. But it serves as a good + -- approximation for the first iteration for the first iteration of linear types. -- Cannot derive Data instance because SDoc is not Data (it stores a function). -- So we do it manually: @@ -241,6 +254,7 @@ instance Data.Data HsWrapper where gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 gfoldl k z (WpLet a1) = z WpLet `k` a1 + gfoldl k z (WpMultCoercion a1) = z WpMultCoercion `k` a1 gunfold k z c = case Data.constrIndex c of 1 -> z WpHole @@ -251,7 +265,8 @@ instance Data.Data HsWrapper where 6 -> k (z WpEvApp) 7 -> k (z WpTyLam) 8 -> k (z WpTyApp) - _ -> k (z WpLet) + 9 -> k (z WpLet) + _ -> k (z WpMultCoercion) toConstr WpHole = wpHole_constr toConstr (WpCompose _ _) = wpCompose_constr @@ -262,6 +277,7 @@ instance Data.Data HsWrapper where toConstr (WpTyLam _) = wpTyLam_constr toConstr (WpTyApp _) = wpTyApp_constr toConstr (WpLet _) = wpLet_constr + toConstr (WpMultCoercion _) = wpMultCoercion_constr dataTypeOf _ = hsWrapper_dataType @@ -270,10 +286,11 @@ hsWrapper_dataType = Data.mkDataType "HsWrapper" [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr - , wpLet_constr] + , wpLet_constr, wpMultCoercion_constr ] wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, - wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr + wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr, + wpMultCoercion_constr :: Data.Constr wpHole_constr = mkHsWrapperConstr "WpHole" wpCompose_constr = mkHsWrapperConstr "WpCompose" wpFun_constr = mkHsWrapperConstr "WpFun" @@ -283,11 +300,12 @@ wpEvApp_constr = mkHsWrapperConstr "WpEvApp" wpTyLam_constr = mkHsWrapperConstr "WpTyLam" wpTyApp_constr = mkHsWrapperConstr "WpTyApp" wpLet_constr = mkHsWrapperConstr "WpLet" +wpMultCoercion_constr = mkHsWrapperConstr "WpMultCoercion" mkHsWrapperConstr :: String -> Data.Constr mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix -wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper +wpFunEmpty :: HsWrapper -> HsWrapper -> Scaled TcType -> HsWrapper wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty (<.>) :: HsWrapper -> HsWrapper -> HsWrapper @@ -296,15 +314,15 @@ c <.> WpHole = c c1 <.> c2 = c1 `WpCompose` c2 mkWpFun :: HsWrapper -> HsWrapper - -> TcType -- the "from" type of the first wrapper + -> (Scaled TcType) -- the "from" type of the first wrapper -> TcType -- either type of the second wrapper (used only when the -- second wrapper is the identity) -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." -> HsWrapper mkWpFun WpHole WpHole _ _ _ = WpHole -mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) +mkWpFun WpHole (WpCast co2) (Scaled w t1) _ _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole (Scaled w _) t2 _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d mkWpCastR :: TcCoercionR -> HsWrapper @@ -375,6 +393,7 @@ hsWrapDictBinders wrap = go wrap go (WpTyLam {}) = emptyBag go (WpTyApp {}) = emptyBag go (WpLet {}) = emptyBag + go (WpMultCoercion {}) = emptyBag collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) -- Collect the outer lambda binders of a HsWrapper, @@ -608,9 +627,9 @@ data EvTypeable -- ^ Dictionary for @Typeable (s t)@, -- given a dictionaries for @s@ and @t@. - | EvTypeableTrFun EvTerm EvTerm - -- ^ Dictionary for @Typeable (s -> t)@, - -- given a dictionaries for @s@ and @t@. + | EvTypeableTrFun EvTerm EvTerm EvTerm + -- ^ Dictionary for @Typeable (s # w -> t)@, + -- given a dictionaries for @w@, @s@, and @t@. | EvTypeableTyLit EvTerm -- ^ Dictionary for a type literal, @@ -893,10 +912,10 @@ evVarsOfTerms = mapUnionVarSet evVarsOfTerm evVarsOfTypeable :: EvTypeable -> VarSet evVarsOfTypeable ev = case ev of - EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e - EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTyLit e -> evVarsOfTerm e + EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e + EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTrFun em e1 e2 -> evVarsOfTerms [em,e1,e2] + EvTypeableTyLit e -> evVarsOfTerm e {- Note [Free vars of EvFun] @@ -937,7 +956,7 @@ pprHsWrapper wrap pp_thing_inside -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> + help it (WpFun f1 f2 (Scaled w t1) _) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+> help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] @@ -946,6 +965,8 @@ pprHsWrapper wrap pp_thing_inside help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] + help it (WpMultCoercion co) = add_parens $ sep [it False, nest 2 (text "<multiplicity coercion>" + <+> pprParendCo co)] pprLamBndr :: Id -> SDoc pprLamBndr v = pprBndr LambdaBind v @@ -992,7 +1013,7 @@ instance Outputable EvCallStack where instance Outputable EvTypeable where ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) + ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> mulArrow (ppr tm) <+> ppr t2) ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index b453633c65..7dfa5ffd65 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -34,6 +34,7 @@ import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.PatSyn +import GHC.Core.Multiplicity ( scaledThing ) import GHC.Unit.Module import GHC.Types.Name @@ -285,12 +286,13 @@ pprSigSkolInfo ctxt ty pprPatSkolInfo :: ConLike -> SDoc pprPatSkolInfo (RealDataCon dc) - = sep [ text "a pattern with constructor:" - , nest 2 $ ppr dc <+> dcolon - <+> pprType (dataConUserType dc) <> comma ] - -- pprType prints forall's regardless of -fprint-explicit-foralls - -- which is what we want here, since we might be saying - -- type variable 't' is bound by ... + = sdocWithDynFlags (\dflags -> + sep [ text "a pattern with constructor:" + , nest 2 $ ppr dc <+> dcolon + <+> pprType (dataConDisplayType dflags dc) <> comma ]) + -- pprType prints forall's regardless of -fprint-explicit-foralls + -- which is what we want here, since we might be saying + -- type variable 't' is bound by ... pprPatSkolInfo (PatSynCon ps) = sep [ text "a pattern with pattern synonym:" @@ -444,6 +446,9 @@ data CtOrigin | InstProvidedOrigin Module ClsInst -- Skolem variable arose when we were testing if an instance -- is solvable or not. + | NonLinearPatternOrigin + | UsageEnvironmentOf Name + -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible -- TypeEqOrigins. This is used when choosing which error of @@ -575,7 +580,7 @@ pprCtOrigin (UnboundOccurrenceOf name) pprCtOrigin (DerivOriginDC dc n _) = hang (ctoHerald <+> text "the" <+> speakNth n <+> text "field of" <+> quotes (ppr dc)) - 2 (parens (text "type" <+> quotes (ppr ty))) + 2 (parens (text "type" <+> quotes (ppr (scaledThing ty)))) where ty = dataConOrigArgTys dc !! (n-1) @@ -650,5 +655,7 @@ pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) pprCtO PatCheckOrigin = text "a pattern-match completeness check" pprCtO ListOrigin = text "an overloaded list" pprCtO StaticOrigin = text "a static form" +pprCtO NonLinearPatternOrigin = text "a non-linear pattern" +pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO BracketOrigin = text "a quotation bracket" pprCtO _ = panic "pprCtOrigin" diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 1f6090c7b7..72a1aee55d 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -50,6 +50,7 @@ import GHC.Types.SrcLoc import GHC.Driver.Types import GHC.Utils.Outputable import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Data.FastString import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Data.Maybe @@ -216,7 +217,7 @@ check_inst sig_inst = do (substTy skol_subst pred) givens <- forM theta $ \given -> do loc <- getCtLocM origin (Just TypeLevel) - let given_pred = substTy skol_subst given + let given_pred = substTy skol_subst (scaledThing given) new_ev <- newEvVar given_pred return CtGiven { ctev_pred = given_pred -- Doesn't matter, make something up diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 2563ff7348..55c0ad4e67 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -34,6 +34,7 @@ module GHC.Tc.Utils.Env( tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendBinderStack, tcExtendLocalTypeEnv, isTypeClosedLetBndr, + tcCheckUsage, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupIdMaybe, tcLookupTyVar, @@ -78,6 +79,10 @@ import GHC.Iface.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType +import GHC.Core.UsageEnv +import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper) +import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult ) +import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) import GHC.Iface.Load import GHC.Builtin.Names import GHC.Builtin.Types @@ -108,6 +113,7 @@ import GHC.Data.Bag import GHC.Data.List.SetOps import GHC.Utils.Error import GHC.Data.Maybe( MaybeErr(..), orElse ) +import GHC.Core.Multiplicity import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Misc ( HasDebugCallStack ) @@ -621,6 +627,28 @@ tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } +-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the +-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the +-- usage environment. See also Note [tcSubMult's wrapper] in TcUnify. +tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper) +tcCheckUsage name id_mult thing_inside + = do { (local_usage, result) <- tcCollectingUsage thing_inside + ; wrapper <- check_then_add_usage local_usage + ; return (result, wrapper) } + where + check_then_add_usage :: UsageEnv -> TcM HsWrapper + -- Checks that the usage of the newly introduced binder is compatible with + -- its multiplicity, and combines the usage of non-new binders to |uenv| + check_then_add_usage uenv + = do { let actual_u = lookupUE uenv name + ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) + ; wrapper <- case actual_u of + Bottom -> return idHsWrapper + Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult + MUsage m -> tcSubMult (UsageEnvironmentOf name) m id_mult + ; tcEmitBindingUsage (deleteUE uenv name) + ; return wrapper } + {- ********************************************************************* * * The TcBinderStack diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index df9cf982ee..d027209d04 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -53,6 +53,7 @@ import GHC.Core ( isOrphan ) import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Tc.Utils.TcType @@ -393,7 +394,7 @@ tcInstInvisibleTyBinder subst (Named (Bndr tv _)) ; return (subst', mkTyVarTy tv') } tcInstInvisibleTyBinder subst (Anon af ty) - | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty) + | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) -- Equality is the *only* constraint currently handled in types. -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep = ASSERT( af == InvisArg ) @@ -500,7 +501,7 @@ newNonTrivialOverloadedLit orig ; let lit_ty = hsLitType hs_lit ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) [synKnownType lit_ty] res_ty $ - \_ -> return () + \_ _ -> return () ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index ca85a087b6..e485b667af 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -69,6 +69,9 @@ module GHC.Tc.Utils.Monad( addMessages, discardWarnings, + -- * Usage environment + tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, + -- * Shared error message stuff: renamer and typechecker mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, @@ -157,6 +160,8 @@ import GHC.Driver.Types import GHC.Unit import GHC.Types.Name.Reader import GHC.Types.Name +import GHC.Core.UsageEnv +import GHC.Core.Multiplicity import GHC.Core.Type import GHC.Tc.Utils.TcType @@ -332,6 +337,7 @@ initTcWithGbl :: HscEnv initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef (emptyBag, emptyBag) + ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { tcl_errs = errs_var, tcl_loc = loc, -- Should be over-ridden very soon! @@ -341,6 +347,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_th_bndrs = emptyNameEnv, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, + tcl_usage = usage_var, tcl_bndrs = [], tcl_lie = lie_var, tcl_tclvl = topTcLevel @@ -625,15 +632,16 @@ newSysName occ = do { uniq <- newUnique ; return (mkSystemName uniq occ) } -newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId -newSysLocalId fs ty +newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId +newSysLocalId fs w ty = do { u <- newUnique - ; return (mkSysLocal fs u ty) } + ; return (mkSysLocal fs u w ty) } -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + ; let mkId' n (Scaled w t) = mkSysLocal fs n w t + ; return (zipWith mkId' (uniqsFromSupply us) tys) } instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique @@ -1191,6 +1199,36 @@ captureConstraints thing_inside Just res -> return (res, lie) } ----------------------- +-- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage +-- information which was collected as part of the execution of +-- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not +-- report any usage information, it's up to the caller to incorporate the +-- returned usage information into the larger context appropriately. +tcCollectingUsage :: TcM a -> TcM (UsageEnv,a) +tcCollectingUsage thing_inside + = do { env0 <- getLclEnv + ; local_usage_ref <- newTcRef zeroUE + ; let env1 = env0 { tcl_usage = local_usage_ref } + ; result <- setLclEnv env1 thing_inside + ; local_usage <- readTcRef local_usage_ref + ; return (local_usage,result) } + +-- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the +-- usage information by @mult@. +tcScalingUsage :: Mult -> TcM a -> TcM a +tcScalingUsage mult thing_inside + = do { (usage, result) <- tcCollectingUsage thing_inside + ; traceTc "tcScalingUsage" (ppr mult) + ; tcEmitBindingUsage $ scaleUE mult usage + ; return result } + +tcEmitBindingUsage :: UsageEnv -> TcM () +tcEmitBindingUsage ue + = do { lcl_env <- getLclEnv + ; let usage = tcl_usage lcl_env + ; updTcRef usage (addUE ue) } + +----------------------- attemptM :: TcRn r -> TcRn (Maybe r) -- (attemptM thing_inside) runs thing_inside -- If thing_inside succeeds, returning r, diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index cc8ac8f737..c33c335ac7 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} +{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -26,6 +26,7 @@ module GHC.Tc.Utils.TcMType ( cloneMetaTyVar, newFmvTyVar, newFskTyVar, + newMultiplicityVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, @@ -126,6 +127,7 @@ import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair import GHC.Types.Unique.Set +import GHC.Core.Multiplicity import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Basic ( TypeOrKind(..) ) @@ -173,7 +175,7 @@ newEvVars theta = mapM newEvVar theta newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar -- Creates new *rigid* variables for predicates newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name ty) } + ; return (mkLocalIdOrCoVar name Many ty) } newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence -- Deals with both equality and non-equality predicates @@ -286,7 +288,7 @@ emitNewExprHole occ ev_id ty newDict :: Class -> [TcType] -> TcM DictId newDict cls tys = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (mkClassPred cls tys)) } + ; return (mkLocalId name Many (mkClassPred cls tys)) } predTypeOccName :: PredType -> OccName predTypeOccName ty = case classifyPredType ty of @@ -925,6 +927,7 @@ writeMetaTyVarRef tyvar ref ty -- Check for level OK -- See Note [Level check when unifying] ; MASSERT2( level_check_ok, level_check_msg ) + -- another level check problem, see #97 -- Check Kinds ok ; MASSERT2( kind_check_ok, kind_msg ) @@ -982,6 +985,9 @@ that can't ever appear in user code, so we're safe! -} +newMultiplicityVar :: TcM TcType +newMultiplicityVar = newFlexiTyVarTy multiplicityTy + newFlexiTyVar :: Kind -> TcM TcTyVar newFlexiTyVar kind = newAnonMetaTyVar TauTv kind @@ -1320,9 +1326,9 @@ collect_cand_qtvs orig_ty is_dep bound dvs ty ----------------- go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs -- Uses accumulating-parameter style - go dv (AppTy t1 t2) = foldlM go dv [t1, t2] - go dv (TyConApp _ tys) = foldlM go dv tys - go dv (FunTy _ arg res) = foldlM go dv [arg, res] + go dv (AppTy t1 t2) = foldlM go dv [t1, t2] + go dv (TyConApp _ tys) = foldlM go dv tys + go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] go dv (LitTy {}) = return dv go dv (CastTy ty co) = do dv1 <- go dv ty collect_cand_qtvs_co orig_ty bound dv1 co @@ -1393,7 +1399,7 @@ collect_cand_qtvs_co orig_ty bound = go_co go_mco dv1 mco go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (FunCo _ co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (FunCo _ w co1 co2) = foldlM go_co dv [w, co1, co2] go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov @@ -1725,6 +1731,10 @@ defaultTyVar default_kind tv = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) ; writeMetaTyVar tv liftedRepTy ; return True } + | isMultiplicityVar tv + = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv) + ; writeMetaTyVar tv manyDataConTy + ; return True } | default_kind -- -XNoPolyKinds and this is a kind var = default_kind_var tv -- so default it to * if possible @@ -2030,8 +2040,7 @@ zonkImplication implic@(Implic { ic_skols = skols , ic_info = info' }) } zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = do { ty' <- zonkTcType (varType var) - ; return (setVarType var ty') } +zonkEvVar var = updateVarTypeAndMultM zonkTcType var zonkWC :: WantedConstraints -> TcM WantedConstraints @@ -2218,9 +2227,7 @@ zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv -- zonkId is used *during* typechecking just to zonk the Id's type zonkId :: TcId -> TcM TcId -zonkId id - = do { ty' <- zonkTcType (idType id) - ; return (Id.setIdType id ty') } +zonkId id = Id.updateIdTypeAndMultM zonkTcType id zonkCoVar :: CoVar -> TcM CoVar zonkCoVar = zonkId @@ -2308,7 +2315,7 @@ tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = setVarType var (tidyType env (varType var)) +tidyEvVar env var = updateVarTypeAndMult (tidyType env) var ---------------- tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo @@ -2333,8 +2340,10 @@ tidySigSkol env cx ty tv_prs where (env', tv') = tidy_tv_bndr env tv - tidy_ty env ty@(FunTy InvisArg arg res) -- Look under c => t - = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res } + tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under c => t + = ty { ft_mult = tidy_ty env w, + ft_arg = tidyType env arg, + ft_res = tidy_ty env res } tidy_ty env ty = tidyType env ty diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 9cc1d79df9..f06cdd7d31 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -134,7 +134,8 @@ module GHC.Tc.Utils.TcType ( mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, mkInfForAllTy, mkInfForAllTys, - mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys, + mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTyMany, + mkVisFunTyMany, mkVisFunTysMany, mkInvisFunTysMany, mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, @@ -155,9 +156,10 @@ module GHC.Tc.Utils.TcType ( Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, - Type.substTy, substTys, substTyWith, substTyWithCoVars, + Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, + substThetaUnchecked, substTyWithUnchecked, substCoUnchecked, substCoWithUnchecked, substTheta, @@ -198,6 +200,7 @@ import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr import GHC.Core.Class +import GHC.Core.Multiplicity import GHC.Types.Var import GHC.Types.ForeignCall import GHC.Types.Var.Set @@ -411,6 +414,9 @@ mkCheckExpType = Check -- for the 'SynType', because you've said positively that it should be an -- Int, and so it shall be. -- +-- You'll also get three multiplicities back: one for each function arrow. See +-- also Note [Linear types] in Multiplicity. +-- -- This is defined here to avoid defining it in GHC.Tc.Gen.Expr boot file. data SyntaxOpType = SynAny -- ^ Any type @@ -804,7 +810,8 @@ tcTyFamInstsAndVisX = go go _ (LitTy {}) = [] go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) ++ go is_invis_arg ty - go is_invis_arg (FunTy _ ty1 ty2) = go is_invis_arg ty1 + go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w + ++ go is_invis_arg ty1 ++ go is_invis_arg ty2 go is_invis_arg ty@(AppTy _ _) = let (ty_head, ty_args) = splitAppTys ty @@ -861,8 +868,8 @@ anyRewritableTyVar ignore_cos role pred ty go _ _ (LitTy {}) = False go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg - go rl bvs (FunTy _ arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || - go rl bvs arg || go rl bvs res + go rl bvs (FunTy _ w arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || + go rl bvs arg || go rl bvs res || go rl bvs w where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 res_rep = getRuntimeRep res go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty @@ -1133,7 +1140,7 @@ mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkInvisFunTys +mkPhiTy = mkInvisFunTysMany --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to @@ -1329,18 +1336,18 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) ----------------------- -tcSplitFunTys :: Type -> ([Type], Type) +tcSplitFunTys :: Type -> ([Scaled Type], Type) tcSplitFunTys ty = case tcSplitFunTy_maybe ty of Nothing -> ([], ty) Just (arg,res) -> (arg:args, res') where (args,res') = tcSplitFunTys res -tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) +tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - | VisArg <- af = Just (arg, res) +tcSplitFunTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | VisArg <- af = Just (Scaled w arg, res) tcSplitFunTy_maybe _ = Nothing -- Note the VisArg guard -- Consider (?x::Int) => Bool @@ -1353,7 +1360,7 @@ tcSplitFunTy_maybe _ = Nothing tcSplitFunTysN :: Arity -- n: Number of desired args -> TcRhoType -> Either Arity -- Number of missing arrows - ([TcSigmaType], -- Arg types (always N types) + ([Scaled TcSigmaType],-- Arg types (always N types) TcSigmaType) -- The rest of the type -- ^ Split off exactly the specified number argument types -- Returns @@ -1369,10 +1376,10 @@ tcSplitFunTysN n ty | otherwise = Left n -tcSplitFunTy :: Type -> (Type, Type) +tcSplitFunTy :: Type -> (Scaled Type, Type) tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) -tcFunArgTy :: Type -> Type +tcFunArgTy :: Type -> Scaled Type tcFunArgTy ty = fst (tcSplitFunTy ty) tcFunResultTy :: Type -> Type @@ -1452,7 +1459,7 @@ tcSplitDFunTy ty = case tcSplitForAllTys ty of { (tvs, rho) -> case splitFunTys rho of { (theta, tau) -> case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }}} + (tvs, map scaledThing theta, clas, tys) }}} tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead = getClassPredTys @@ -1544,10 +1551,10 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 -- Make sure we handle all FunTy cases since falling through to the -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked -- kind variable, which causes things to blow up. - go env (FunTy _ arg1 res1) (FunTy _ arg2 res2) - = go env arg1 arg2 && go env res1 res2 - go env ty (FunTy _ arg res) = eqFunTy env arg res ty - go env (FunTy _ arg res) ty = eqFunTy env arg res ty + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = go env w1 w2 && go env arg1 arg2 && go env res1 res2 + go env ty (FunTy _ w arg res) = eqFunTy env w arg res ty + go env (FunTy _ w arg res) ty = eqFunTy env w arg res ty -- See Note [Equality on AppTys] in GHC.Core.Type go env (AppTy s1 t1) ty2 @@ -1582,25 +1589,25 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is + -- @eqFunTy w arg res ty@ is True when @ty@ equals @FunTy w arg res@. This is -- sometimes hard to know directly because @ty@ might have some casts -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or -- res is unzonked/unflattened. Thus this function, which handles this -- corner case. - eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool + eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool -- Last arg is /not/ FunTy - eqFunTy env arg res ty@(AppTy{}) = get_args ty [] + eqFunTy env w arg res ty@(AppTy{}) = get_args ty [] where get_args :: Type -> [Type] -> Bool get_args (AppTy f x) args = get_args f (x:args) get_args (CastTy t _) args = get_args t args get_args (TyConApp tc tys) args | tc == funTyCon - , [_, _, arg', res'] <- tys ++ args - = go env arg arg' && go env res res' + , [w', _, _, arg', res'] <- tys ++ args + = go env w w' && go env arg arg' && go env res res' get_args _ _ = False - eqFunTy _ _ _ _ = False + eqFunTy _ _ _ _ _ = False {- ********************************************************************* * * @@ -1850,7 +1857,7 @@ isInsolubleOccursCheck eq_rel tv ty go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq] NomEq -> go t1 || go t2 ReprEq -> go t1 - go (FunTy _ t1 t2) = go t1 || go t2 + go (FunTy _ w t1 t2) = go w || go t1 || go t2 go (ForAllTy (Bndr tv' _) inner_ty) | tv' == tv = False | otherwise = go (varType tv') || go inner_ty @@ -2105,8 +2112,9 @@ isAlmostFunctionFree (TyConApp tc args) | isTypeFamilyTyCon tc = False | otherwise = all isAlmostFunctionFree args isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr) -isAlmostFunctionFree (FunTy _ ty1 ty2) = isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 +isAlmostFunctionFree (FunTy _ w ty1 ty2) = isAlmostFunctionFree w && + isAlmostFunctionFree ty1 && + isAlmostFunctionFree ty2 isAlmostFunctionFree (LitTy {}) = True isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty isAlmostFunctionFree (CoercionTy {}) = True @@ -2447,7 +2455,7 @@ sizeType = go -- size ordering is sound, but why is this better? -- I came across this when investigating #14010. go (LitTy {}) = 1 - go (FunTy _ arg res) = go arg + go res + 1 + go (FunTy _ w arg res) = go w + go arg + go res + 1 go (AppTy fun arg) = go fun + go arg go (ForAllTy (Bndr tv vis) ty) | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index efe8301650..a6711abcc1 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -16,6 +16,7 @@ module GHC.Tc.Utils.Unify ( tcWrapResult, tcWrapResultO, tcWrapResultMono, tcSkolemise, tcSkolemiseScoped, tcSkolemiseET, tcSubType, tcSubTypeSigma, tcSubTypePat, + tcSubMult, checkConstraints, checkTvConstraints, buildImplicationFor, buildTvImplication, emitResidualTvConstraint, @@ -51,6 +52,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Env import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.Multiplicity import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Core.Predicate @@ -145,7 +147,7 @@ matchExpectedFunTys :: forall a. -> UserTypeCtxt -> Arity -> ExpRhoType -- Skolemised - -> ([ExpSigmaType] -> ExpRhoType -> TcM a) + -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (_, wrap) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, @@ -173,11 +175,11 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside go acc_arg_tys n ty | Just ty' <- tcView ty = go acc_arg_tys n ty' - go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) + go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) = ASSERT( af == VisArg ) - do { (wrap_res, result) <- go (mkCheckExpType arg_ty : acc_arg_tys) + do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) (n-1) res_ty - ; let fun_wrap = mkWpFun idHsWrapper wrap_res arg_ty res_ty doc + ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc ; return ( fun_wrap, result ) } where doc = text "When inferring the argument type of a function with type" <+> @@ -209,25 +211,25 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside defer acc_arg_tys n (mkCheckExpType ty) ------------ - defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) + defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) defer acc_arg_tys n fun_ty = do { more_arg_tys <- replicateM n newInferExpType ; res_ty <- newInferExpType - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty + ; result <- thing_inside (reverse acc_arg_tys ++ (map unrestricted more_arg_tys)) res_ty ; more_arg_tys <- mapM readExpType more_arg_tys ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty + ; let unif_fun_ty = mkVisFunTysMany more_arg_tys res_ty ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty -- Not a good origin at all :-( ; return (wrap, result) } ------------ - mk_ctxt :: [ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) mk_ctxt arg_tys res_ty env = do { (env', ty) <- zonkTidyTcType env (mkVisFunTys arg_tys' res_ty) ; return ( env', mk_fun_tys_msg herald ty arity) } where - arg_tys' = map (checkingExpType "matchExpectedFunTys") (reverse arg_tys) + arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) (reverse arg_tys) -- this is safe b/c we're called from "go" -- Like 'matchExpectedFunTys', but used when you have an "actual" type, @@ -237,7 +239,7 @@ matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys] -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType -> Arity -> TcSigmaType - -> TcM (HsWrapper, [TcSigmaType], TcRhoType) + -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType) -- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) -- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) -- and res_ty is a RhoType @@ -266,12 +268,12 @@ matchActualFunTySigma :: SDoc -- See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType - -> (Arity, [TcSigmaType]) -- Total number of value args in the call, and + -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and -- types of values args to which function has -- been applied already (reversed) -- Both are used only for error messages) -> TcSigmaType -- Type to analyse - -> TcM (HsWrapper, TcSigmaType, TcSigmaType) + -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType) -- See Note [matchActualFunTys error handling] for all these arguments -- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty @@ -295,7 +297,7 @@ matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty where go :: TcSigmaType -- The remainder of the type as we're processing - -> TcM (HsWrapper, TcSigmaType, TcSigmaType) + -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType) go ty | Just ty' <- tcView ty = go ty' go ty @@ -306,9 +308,9 @@ matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty where (tvs, theta, _) = tcSplitSigmaTy ty - go (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) + go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) = ASSERT( af == VisArg ) - return (idHsWrapper, arg_ty, res_ty) + return (idHsWrapper, Scaled w arg_ty, res_ty) go ty@(TyVarTy tv) | isMetaTyVar tv @@ -338,9 +340,9 @@ matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty defer fun_ty = do { arg_ty <- newOpenFlexiTyVarTy ; res_ty <- newOpenFlexiTyVarTy - ; let unif_fun_ty = mkVisFunTy arg_ty res_ty + ; let unif_fun_ty = mkVisFunTyMany arg_ty res_ty ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, arg_ty, res_ty) } + ; return (mkWpCastN co, unrestricted arg_ty, res_ty) } ------------ mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) @@ -405,7 +407,7 @@ matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> -- Postcondition: (T k1 k2 k3 a b c) is well-kinded matchExpectedTyConApp tc orig_ty - = ASSERT(tc /= funTyCon) go orig_ty + = ASSERT(not $ isFunTyCon tc) go orig_ty where go ty | Just ty' <- tcView ty @@ -475,7 +477,7 @@ matchExpectedAppTy orig_ty ; return (co, (ty1, ty2)) } orig_kind = tcTypeKind orig_ty - kind1 = mkVisFunTy liftedTypeKind orig_kind + kind1 = mkVisFunTyMany liftedTypeKind orig_kind kind2 = liftedTypeKind -- m :: * -> k -- arg type :: * @@ -723,6 +725,48 @@ to a UserTypeCtxt of GenSigCtxt. Why? -} +-- Note [tcSubMult's wrapper] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There is no notion of multiplicity coercion in Core, therefore the wrapper +-- returned by tcSubMult (and derived function such as tcCheckUsage and +-- checkManyPattern) is quite unlike any other wrapper: it checks whether the +-- coercion produced by the constraint solver is trivial and disappears (it +-- produces a type error is the constraint is not trivial). See [Checking +-- multiplicity coercions] in TcEvidence. +-- +-- This wrapper need to be placed in the term, otherwise checking of the +-- eventual coercion won't be triggered during desuraging. But it can be put +-- anywhere, since it doesn't affect the desugared code. +-- +-- Why do we check this in the desugarer? It's a convenient place, since it's +-- right after all the constraints are solved. We need the constraints to be +-- solved to check whether they are trivial or not. Plus there are precedent for +-- type errors during desuraging (such as the levity polymorphism +-- restriction). An alternative would be to have a kind of constraints which can +-- only produce trivial evidence, then this check would happen in the constraint +-- solver. +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcSubMult origin (MultMul w1 w2) w_expected = + do { w1 <- tcSubMult origin w1 w_expected + ; w2 <- tcSubMult origin w2 w_expected + ; return (w1 <.> w2) } + -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is + -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p + -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating + -- multiplicities] in Multiplicity. +tcSubMult origin w_actual w_expected = + case submult w_actual w_expected of + Submult -> return WpHole + Unknown -> tcEqMult origin w_actual w_expected + +tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcEqMult origin w_actual w_expected = do + { + -- Note that here we do not call to `submult`, so we check + -- for strict equality. + ; coercion <- uType TypeLevel origin w_actual w_expected + ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion } + {- ********************************************************************** %* * ExpType functions: tcInfer, instantiateAndFillInferResult @@ -1308,10 +1352,11 @@ uType t_or_k origin orig_ty1 orig_ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' -- Functions (or predicate functions) just check the two parts - go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2) + go (FunTy _ w1 fun1 arg1) (FunTy _ w2 fun2 arg2) = do { co_l <- uType t_or_k origin fun1 fun2 ; co_r <- uType t_or_k origin arg1 arg2 - ; return $ mkFunCo Nominal co_l co_r } + ; co_w <- uType t_or_k origin w1 w2 + ; return $ mkFunCo Nominal co_w co_l co_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) @@ -1975,9 +2020,9 @@ matchExpectedFunKind hs_ty n k = go n k Indirect fun_kind -> go n fun_kind Flexi -> defer n k } - go n (FunTy _ arg res) + go n (FunTy _ w arg res) = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } + ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) } go n other = defer n other @@ -1985,7 +2030,7 @@ matchExpectedFunKind hs_ty n k = go n k defer n k = do { arg_kinds <- newMetaKindVars n ; res_kind <- newMetaKindVar - ; let new_fun = mkVisFunTys arg_kinds res_kind + ; let new_fun = mkVisFunTysMany arg_kinds res_kind origin = TypeEqOrigin { uo_actual = k , uo_expected = new_fun , uo_thing = Just (ppr hs_ty) @@ -2156,10 +2201,10 @@ preCheck dflags ty_fam_ok tv ty | bad_tc tc = MTVU_Bad | otherwise = mapM fast_check tys >> ok fast_check (LitTy {}) = ok - fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r}) + fast_check (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) | InvisArg <- af , not impredicative_ok = MTVU_Bad - | otherwise = fast_check a >> fast_check r + | otherwise = fast_check w >> fast_check a >> fast_check r fast_check (AppTy fun arg) = fast_check fun >> fast_check arg fast_check (CastTy ty co) = fast_check ty >> fast_check_co co fast_check (CoercionTy co) = fast_check_co co diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot index 311dbf66aa..a54107fe07 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs-boot +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -3,9 +3,10 @@ module GHC.Tc.Utils.Unify where import GHC.Prelude import GHC.Tc.Utils.TcType ( TcTauType ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Evidence ( TcCoercion ) +import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper ) +import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Hs.Expr ( HsExpr ) -import GHC.Hs.Type ( HsType ) +import GHC.Hs.Type ( HsType, Mult ) import GHC.Hs.Extension ( GhcRn ) -- This boot file exists only to tie the knot between @@ -13,3 +14,5 @@ import GHC.Hs.Extension ( GhcRn ) unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion + +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 4372a39e9d..05eb4d9ba4 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -36,7 +36,7 @@ module GHC.Tc.Utils.Zonk ( zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, zonkTyBndrs, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypes, zonkTcTypesToTypesX, + zonkTcTypesToTypes, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, zonkTyVarOcc, zonkCoToCo, zonkEvBinds, zonkTcEvBinds, @@ -80,6 +80,7 @@ import GHC.Data.Bag import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Types.Unique.FM +import GHC.Core.Multiplicity import GHC.Core import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) @@ -372,11 +373,11 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids -- to its final form. The TyVarEnv give zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v - = do ty' <- zonkTcTypeToTypeX env (idType v) + = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) ensureNotLevPoly ty' (text "In the type of binder" <+> quotes (ppr v)) - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) + return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mapM (zonkIdBndr env) ids @@ -401,11 +402,7 @@ zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar -- Works for dictionaries and coercions -- Does not extend the ZonkEnv zonkEvBndr env var - = do { let var_ty = varType var - ; ty <- - {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} - zonkTcTypeToTypeX env var_ty - ; return (setVarType var ty) } + = updateVarTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var {- zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm @@ -583,10 +580,10 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs where zonk_val_bind env lbind | has_sig - , (L loc bind@(FunBind { fun_id = L mloc mono_id + , (L loc bind@(FunBind { fun_id = (L mloc mono_id) , fun_matches = ms , fun_ext = co_fn })) <- lbind - = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id + = do { new_mono_id <- updateVarTypeAndMultM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn @@ -674,7 +671,7 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkTcTypesToTypesX env arg_tys + ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' @@ -1043,7 +1040,7 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; return (env2, WpCompose c1' c2') } zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkTcTypeToTypeX env2 t1 + ; t1' <- zonkScaledTcTypeToTypeX env2 t1 ; return (env2, WpFun c1' c2' t1' d) } zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co ; return (env, WpCast co') } @@ -1058,6 +1055,8 @@ zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty ; return (env, WpTyApp ty') } zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ; return (env1, WpLet bs') } +zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co + ; return (env, WpMultCoercion co') } ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) @@ -1199,6 +1198,7 @@ zonkStmt env _ (LetStmt x (L l binds)) zonkStmt env zBody (BindStmt xbs pat body) = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs) + ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs) ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs) ; new_body <- zBody env1 body ; (env2, new_pat) <- zonkPat env1 pat @@ -1209,6 +1209,7 @@ zonkStmt env zBody (BindStmt xbs pat body) , BindStmt (XBindStmtTc { xbstc_bindOp = new_bind , xbstc_boundResultType = new_bind_ty + , xbstc_boundResultMult = new_w , xbstc_failOp = new_fail }) new_pat new_body) } @@ -1617,10 +1618,11 @@ zonkEvTypeable env (EvTypeableTyApp t1 t2) = do { t1' <- zonkEvTerm env t1 ; t2' <- zonkEvTerm env t2 ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable env (EvTypeableTrFun t1 t2) - = do { t1' <- zonkEvTerm env t1 +zonkEvTypeable env (EvTypeableTrFun tm t1 t2) + = do { tm' <- zonkEvTerm env tm + ; t1' <- zonkEvTerm env t1 ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun t1' t2') } + ; return (EvTypeableTrFun tm' t1' t2') } zonkEvTypeable env (EvTypeableTyLit t1) = do { t1' <- zonkEvTerm env t1 ; return (EvTypeableTyLit t1') } @@ -1805,6 +1807,9 @@ commitFlexi flexi tv zonked_kind | isRuntimeRepTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) ; return liftedRepTy } + | isMultiplicityTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) + ; return manyDataConTy } | otherwise -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) ; return (anyTypeOfKind zonked_kind) } @@ -1871,12 +1876,20 @@ zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty zonkTcTypesToTypes :: [TcType] -> TcM [Type] zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys +zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType) +zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m + <*> zonkTcTypeToTypeX env ty + zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion (zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) = mapTyCoX zonk_tycomapper +zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type] +zonkScaledTcTypesToTypesX env scaled_tys = + mapM (zonkScaledTcTypeToTypeX env) scaled_tys + zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) = do { ty' <- zonkTcTypeToTypeX ze ty diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 32dfc16ea3..c9eec9838f 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -34,7 +34,7 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes ) -import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName ) +import GHC.Builtin.Types ( heqTyConName, eqTyConName, coercibleTyConName, manyDataConTy ) import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) @@ -711,7 +711,7 @@ check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt (theta, tau) = tcSplitPhiTy phi (env', tvbs') = tidyTyCoVarBinders env tvbs -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty) +check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ _ arg_ty res_ty) = do { check_type (ve{ve_rank = arg_rank}) arg_ty ; check_type (ve{ve_rank = res_rank}) res_ty } where @@ -1635,17 +1635,24 @@ tcInstHeadTyNotSynonym :: Type -> Bool tcInstHeadTyNotSynonym ty = case ty of -- Do not use splitTyConApp, -- because that expands synonyms! - TyConApp tc _ -> not (isTypeSynonymTyCon tc) + TyConApp tc _ -> not (isTypeSynonymTyCon tc) || tc == unrestrictedFunTyCon + -- Allow (->), e.g. instance Category (->), + -- even though it's a type synonym for FUN 'Many _ -> True tcInstHeadTyAppAllTyVars :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head -- These must be a constructor applied to type variable arguments -- or a type-level literal. --- But we allow kind instantiations. +-- But we allow +-- 1) kind instantiations +-- 2) the type (->) = FUN 'Many, even though it's not in this form. tcInstHeadTyAppAllTyVars ty | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) - = ok (filterOutInvisibleTypes tc tys) -- avoid kinds + = let tys' = filterOutInvisibleTypes tc tys -- avoid kinds + tys'' | tc == funTyCon, tys_h:tys_t <- tys', tys_h `eqType` manyDataConTy = tys_t + | otherwise = tys' + in ok tys'' | LitTy _ <- ty = True -- accept type literals (#13833) | otherwise = False @@ -1663,7 +1670,7 @@ dropCasts :: Type -> Type -- To consider: drop only HoleCo casts dropCasts (CastTy ty _) = dropCasts ty dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) -dropCasts ty@(FunTy _ t1 t2) = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 } +dropCasts ty@(FunTy _ w t1 t2) = ty { ft_mult = dropCasts w, ft_arg = dropCasts t1, ft_res = dropCasts t2 } dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy @@ -2831,7 +2838,7 @@ fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys fvType (LitTy {}) = [] fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (FunTy _ arg res) = fvType arg ++ fvType res +fvType (FunTy _ w arg res) = fvType w ++ fvType arg ++ fvType res fvType (ForAllTy (Bndr tv _) ty) = fvType (tyVarKind tv) ++ filter (/= tv) (fvType ty) @@ -2848,7 +2855,7 @@ sizeType (TyVarTy {}) = 1 sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys sizeType (LitTy {}) = 1 sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1 +sizeType (FunTy _ w arg res) = sizeType w + sizeType arg + sizeType res + 1 sizeType (ForAllTy _ ty) = sizeType ty sizeType (CastTy ty _) = sizeType ty sizeType (CoercionTy _) = 0 diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 1a74f417d8..75bd004dc1 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -570,7 +570,7 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; tys' <- mapM cvt_arg strtys - ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') } + ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon (map hsLinear tys')) } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c @@ -582,7 +582,8 @@ cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') } + ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon (hsLinear st1') + (hsLinear st2')) } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs @@ -625,7 +626,7 @@ cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty - ; returnL $ mk_gadt_decl c' (PrefixCon args) ty'} + ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name") @@ -1464,7 +1465,23 @@ cvtTypeKind ty_str ty _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnL (HsFunTy noExtField x'' y'') + returnL (HsFunTy noExtField HsUnrestrictedArrow x'' y'') + | otherwise + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon))) + tys' + MulArrowT + | Just normals <- m_normals + , [w',x',y'] <- normals -> do + x'' <- case unLoc x' of + HsFunTy{} -> returnL (HsParTy noExtField x') + HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 + HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 + _ -> return $ + parenthesizeHsType sigPrec x' + let y'' = parenthesizeHsType sigPrec y' + w'' = hsTypeToArrow w' + returnL (HsFunTy noExtField w'' x'' y'') | otherwise -> mk_apps (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) @@ -1597,6 +1614,13 @@ cvtTypeKind ty_str ty _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } +hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs +hsTypeToArrow w = case unLoc w of + HsTyVar _ _ (L _ (isExact_maybe -> Just n)) + | n == oneDataConName -> HsLinearArrow + | n == manyDataConName -> HsUnrestrictedArrow + _ -> HsExplicitMult w + -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only -- contain data constructor names. See #15572/#17394. We use this function to diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 077d6d913e..fd504eda30 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -71,6 +71,7 @@ import GHC.Data.Maybe ( orElse ) import GHC.Core.Type ( Type ) import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) import GHC.Core.DataCon ( splitDataProductType_maybe ) +import GHC.Core.Multiplicity ( scaledThing ) {- ************************************************************************ @@ -1913,7 +1914,7 @@ strictifyDictDmd ty dmd = case getUseDmd dmd of -- smells like reboxing; results in CBV boxed -- -- TODO revisit this if we ever do boxity analysis - | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd (map scaledThing inst_con_arg_tys) dmds of JD {sd = s,ud = a} -> JD (Str s) (Use n a) -- TODO could optimize with an aborting variant of zipWith since -- the superclass dicts are always a prefix diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 4395ce7fd9..010100e98e 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -40,21 +40,23 @@ module GHC.Types.Id ( mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, mkUserLocal, mkUserLocalOrCoVar, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkScaledTemplateLocal, mkWorkerId, -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, + idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails, recordSelectorTyCon, -- ** Modifying an Id - setIdName, setIdUnique, GHC.Types.Id.setIdType, + setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult, + updateIdTypeAndMult, updateIdTypeAndMultM, setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, - transferPolyIdInfo, + transferPolyIdInfo, scaleIdBy, -- ** Predicates on Ids isImplicitId, isDeadBinder, @@ -154,6 +156,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Data.FastString import GHC.Utils.Misc +import GHC.Core.Multiplicity -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, @@ -191,6 +194,18 @@ idUnique = Var.varUnique idType :: Id -> Kind idType = Var.varType +idMult :: Id -> Mult +idMult = Var.varMult + +idScaledType :: Id -> Scaled Type +idScaledType id = Scaled (idMult id) (idType id) + +scaleIdBy :: Mult -> Id -> Id +scaleIdBy = Var.scaleVarBy + +setIdMult :: Id -> Mult -> Id +setIdMult = Var.setVarMult + setIdName :: Id -> Name -> Id setIdName = Var.setVarName @@ -202,6 +217,12 @@ setIdUnique = Var.setVarUnique setIdType :: Id -> Type -> Id setIdType id ty = seqType ty `seq` Var.setVarType id ty +updateIdTypeAndMult :: (Type -> Type) -> Id -> Id +updateIdTypeAndMult = Var.updateVarTypeAndMult + +updateIdTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id +updateIdTypeAndMultM = Var.updateVarTypeAndMultM + setIdExported :: Id -> Id setIdExported = Var.setIdExported @@ -215,7 +236,7 @@ localiseId id | ASSERT( isId id ) isLocalId id && isInternalName name = id | otherwise - = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) + = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id) where name = idName id @@ -270,26 +291,31 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkLocalId :: HasDebugCallStack => Name -> Type -> Id -mkLocalId name ty = ASSERT( not (isCoVarType ty) ) - mkLocalIdWithInfo name ty vanillaIdInfo +mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id +mkLocalId name w ty = ASSERT( not (isCoVarType ty) ) + mkLocalIdWithInfo name w ty vanillaIdInfo -- | Make a local CoVar mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty = ASSERT( isCoVarType ty ) - Var.mkLocalVar CoVarId name ty vanillaIdInfo + Var.mkLocalVar CoVarId name Many ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Type -> Id -mkLocalIdOrCoVar name ty - | isCoVarType ty = mkLocalCoVar name ty - | otherwise = mkLocalId name ty +mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id +mkLocalIdOrCoVar name w ty + -- We should ASSERT(eqType w Many) in the isCoVarType case. + -- However, currently this assertion does not hold. + -- In tests with -fdefer-type-errors, such as T14584a, + -- we create a linear 'case' where the scrutinee is a coercion + -- (see castBottomExpr). This problem is covered by #17291. + | isCoVarType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name w ty -- proper ids only; no covars! -mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) ) - Var.mkLocalVar VanillaId name ty info +mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id +mkLocalIdWithInfo name w ty info = ASSERT( not (isCoVarType ty) ) + Var.mkLocalVar VanillaId name w ty info -- Note [Free type variables] -- | Create a local 'Id' that is marked as exported. @@ -306,31 +332,31 @@ mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaId -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- that are created by the compiler out of thin air -mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkSystemVarName uniq fs) ty +mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id +mkSysLocal fs uniq w ty = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkSystemVarName uniq fs) w ty -- | Like 'mkSysLocal', but checks to see if we have a covar type -mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id -mkSysLocalOrCoVar fs uniq ty - = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty +mkSysLocalOrCoVar :: FastString -> Unique -> Mult -> Type -> Id +mkSysLocalOrCoVar fs uniq w ty + = mkLocalIdOrCoVar (mkSystemVarName uniq fs) w ty -mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) +mkSysLocalM :: MonadUnique m => FastString -> Mult -> Type -> m Id +mkSysLocalM fs w ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq w ty)) -mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalOrCoVarM fs ty - = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Mult -> Type -> m Id +mkSysLocalOrCoVarM fs w ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq w ty)) -- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize -mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkInternalName uniq occ loc) ty +mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id +mkUserLocal occ uniq w ty loc = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkInternalName uniq occ loc) w ty -- | Like 'mkUserLocal', but checks if we have a coercion type -mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocalOrCoVar occ uniq ty loc - = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty +mkUserLocalOrCoVar :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq w ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) w ty {- Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -341,11 +367,14 @@ instantiated before use. -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty - = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) Many ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty +mkTemplateLocal i ty = mkScaledTemplateLocal i (unrestricted ty) + +mkScaledTemplateLocal :: Int -> Scaled Type -> Id +mkScaledTemplateLocal i (Scaled w ty) = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) w ty -- "OrCoVar" since this is used in a superclass selector, -- and "~" and "~~" have coercion "superclasses". diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 9fdbb62a6e..3bd7fecd70 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -46,6 +46,7 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Opt.ConstantFold import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.FamInstEnv import GHC.Core.Coercion @@ -369,6 +370,45 @@ in wrap_unf in mkDataConRep, and the lack of a binding happens in GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no implicit bindings. +Note [Records and linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the fields, in a record constructor, are linear, because there is no syntax +to specify the type of record field. There will be (see the proposal +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#records-and-projections +), but it isn't implemented yet. + +Projections of records can't be linear: + + data Foo = MkFoo { a :: A, b :: B } + +If we had + + a :: Foo #-> A + +We could write + + bad :: A #-> B #-> A + bad x y = a (MkFoo { a=x, b=y }) + +There is an exception: if `b` (more generally all the fields besides `a`) is +unrestricted, then is perfectly possible to have a linear projection. Such a +linear projection has as simple definition. + + data Bar = MkBar { c :: C, d # Many :: D } + + c :: Bar #-> C + c MkBar{ c=x, d=_} = x + +The `# Many` syntax, for records, does not exist yet. But there is one important +special case which already happens: when there is a single field (usually a +newtype). + + newtype Baz = MkBaz { unbaz :: E } + +unbaz could be linear. And, in fact, it is linear in the proposal design. + +However, this hasn't been implemented yet. + ************************************************************************ * * \subsection{Dictionary selectors} @@ -389,6 +429,18 @@ Then the top-level type for op is forall b. Ord b => a -> b -> b +Note [Type classes and linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Constraints, in particular type classes, don't have attached linearity +information. Implicitly, they are all unrestricted. See the linear types proposal, +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst . + +When translating to core `C => ...` is always translated to an unrestricted +arrow `C # Many -> ...`. + +Therefore there is no loss of generality if we make all selectors unrestricted. + -} mkDictSelId :: Name -- Name of one of the *value* selectors @@ -407,8 +459,9 @@ mkDictSelId name clas val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name sel_ty = mkInvisForAllTys tyvars $ - mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ - getNth arg_tys val_index + mkInvisFunTyMany (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + scaledThing (getNth arg_tys val_index) + -- See Note [Type classes and linear types] base_info = noCafIdInfo `setArityInfo` 1 @@ -463,7 +516,7 @@ mkDictSelRhs clas val_index the_arg_id = getNth arg_ids val_index pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 pred - arg_ids = mkTemplateLocalsNum 2 arg_tys + arg_ids = mkTemplateLocalsNum 2 (map scaledThing arg_tys) rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id) @@ -527,7 +580,7 @@ mkDataConWorkId wkr_name data_con `setInlinePragInfo` dataConWrapperInlinePragma `setUnfoldingInfo` newtype_unf `setLevityInfoWithType` wkr_ty - id_arg1 = mkTemplateLocal 1 (head arg_tys) + id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs newtype_unf = ASSERT2( isVanillaDataCon data_con && isSingleton arg_tys @@ -689,13 +742,13 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs tycon = dataConTyCon data_con -- The representation TyCon (not family) - wrap_ty = dataConUserType data_con + wrap_ty = dataConWrapperType data_con ev_tys = eqSpecPreds eq_spec ++ theta - all_arg_tys = ev_tys ++ orig_arg_tys + all_arg_tys = (map unrestricted ev_tys) ++ orig_arg_tys ev_ibangs = map (const HsLazy) ev_tys orig_bangs = dataConSrcBangs data_con - wrap_arg_tys = theta ++ orig_arg_tys + wrap_arg_tys = (map unrestricted theta) ++ orig_arg_tys wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the @@ -704,8 +757,10 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con new_tycon = isNewTyCon tycon arg_ibangs | new_tycon - = ASSERT( isSingleton orig_arg_tys ) - [HsLazy] -- See Note [HsImplBangs for newtypes] + = map (const HsLazy) orig_arg_tys -- See Note [HsImplBangs for newtypes] + -- orig_arg_tys should be a singleton, but + -- if a user declared a wrong newtype we + -- detect this later (see test T2334A) | otherwise = case mb_bangs of Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) @@ -914,9 +969,9 @@ case of a newtype constructor, we simply hardcode its dcr_bangs field to -} ------------------------- -newLocal :: Type -> UniqSM Var -newLocal ty = do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } +newLocal :: Scaled Type -> UniqSM Var +newLocal (Scaled w ty) = do { uniq <- getUniqueM + ; return (mkSysLocalOrCoVar (fsLit "dt") uniq w ty) } -- We should not have "OrCoVar" here, this is a bug (#17545) @@ -928,7 +983,7 @@ newLocal ty = do { uniq <- getUniqueM dataConSrcToImplBang :: DynFlags -> FamInstEnvs - -> Type + -> Scaled Type -> HsSrcBang -> HsImplBang @@ -945,17 +1000,17 @@ dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) dataConSrcToImplBang dflags fam_envs arg_ty (HsSrcBang _ unpk_prag SrcStrict) - | isUnliftedType arg_ty + | isUnliftedType (scaledThing arg_ty) = HsLazy -- For !Int#, say, use HsLazy -- See Note [Data con wrappers and unlifted types] | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas -- Don't unpack if we aren't optimising; rather arbitrarily, -- we use -fomit-iface-pragmas as the indication - , let mb_co = topNormaliseType_maybe fam_envs arg_ty + , let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) -- Unwrap type families and newtypes - arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } - , isUnpackableType dflags fam_envs arg_ty' + arg_ty' = case mb_co of { Just (_,ty) -> scaledSet arg_ty ty; Nothing -> arg_ty } + , isUnpackableType dflags fam_envs (scaledThing arg_ty') , (rep_tys, _) <- dataConArgUnpack arg_ty' , case unpk_prag of NoSrcUnpack -> @@ -974,9 +1029,9 @@ dataConSrcToImplBang dflags fam_envs arg_ty -- | Wrappers/Workers and representation following Unpack/Strictness -- decisions dataConArgRep - :: Type + :: Scaled Type -> HsImplBang - -> ([(Type,StrictnessMark)] -- Rep types + -> ([(Scaled Type,StrictnessMark)] -- Rep types ,(Unboxer,Boxer)) dataConArgRep arg_ty HsLazy @@ -989,9 +1044,9 @@ dataConArgRep arg_ty (HsUnpack Nothing) | (rep_tys, wrappers) <- dataConArgUnpack arg_ty = (rep_tys, wrappers) -dataConArgRep _ (HsUnpack (Just co)) +dataConArgRep (Scaled w _) (HsUnpack (Just co)) | let co_rep_ty = coercionRKind co - , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty + , (rep_tys, wrappers) <- dataConArgUnpack (Scaled w co_rep_ty) = (rep_tys, wrapCo co co_rep_ty wrappers) @@ -1000,14 +1055,14 @@ wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty = (unboxer, boxer) where - unboxer arg_id = do { rep_id <- newLocal rep_ty + unboxer arg_id = do { rep_id <- newLocal (Scaled (idMult arg_id) rep_ty) ; (rep_ids, rep_fn) <- unbox_rep rep_id ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) ; return (rep_ids, Let co_bind . rep_fn) } boxer = Boxer $ \ subst -> do { (rep_ids, rep_expr) <- case box_rep of - UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) + UnitBox -> do { rep_id <- newLocal (linear $ TcType.substTy subst rep_ty) ; return ([rep_id], Var rep_id) } Boxer boxer -> boxer subst ; let sco = substCoUnchecked subst co @@ -1025,28 +1080,30 @@ unitBoxer = UnitBox ------------------------- dataConArgUnpack - :: Type - -> ( [(Type, StrictnessMark)] -- Rep types + :: Scaled Type + -> ( [(Scaled Type, StrictnessMark)] -- Rep types , (Unboxer, Boxer) ) -dataConArgUnpack arg_ty +dataConArgUnpack (Scaled arg_mult arg_ty) | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty , Just con <- tyConSingleAlgDataCon_maybe tc -- NB: check for an *algebraic* data type -- A recursive newtype might mean that -- 'arg_ty' is a newtype - , let rep_tys = dataConInstArgTys con tc_args + , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args = ASSERT( null (dataConExTyCoVars con) ) -- Note [Unpacking GADTs and existentials] ( rep_tys `zip` dataConRepStrictness con ,( \ arg_id -> do { rep_ids <- mapM newLocal rep_tys + ; let r_mult = idMult arg_id + ; let rep_ids' = map (scaleIdBy r_mult) rep_ids ; let unbox_fn body = mkSingleAltCase (Var arg_id) arg_id - (DataAlt con) rep_ids body + (DataAlt con) rep_ids' body ; return (rep_ids, unbox_fn) } , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys + do { rep_ids <- mapM (newLocal . TcType.substScaledTyUnchecked subst) rep_tys ; return (rep_ids, Var (dataConWorkId con) `mkTyApps` (substTysUnchecked subst tc_args) `mkVarApps` rep_ids ) } ) ) @@ -1078,7 +1135,7 @@ isUnpackableType dflags fam_envs ty dc_name = getName con dcs' = dcs `extendNameSet` dc_name - ok_arg dcs (ty, bang) + ok_arg dcs (Scaled _ ty, bang) = not (attempt_unpack bang) || ok_ty dcs norm_ty where norm_ty = topNormaliseType fam_envs ty @@ -1237,7 +1294,7 @@ mkPrimOpId prim_op = id where (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) + ty = mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax @@ -1413,7 +1470,7 @@ seqId = pcMiscPrelId seqName ty info ty = mkInfForAllTy runtimeRep2TyVar $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] - $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) + $ mkVisFunTyMany alphaTy (mkVisFunTyMany openBetaTy openBetaTy) [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ @@ -1424,13 +1481,13 @@ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) oneShotId :: Id -- See Note [The oneShot function] oneShotId = pcMiscPrelId oneShotName ty info @@ -1439,8 +1496,8 @@ oneShotId = pcMiscPrelId oneShotName ty info `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] - (mkVisFunTy fun_ty fun_ty) - fun_ty = mkVisFunTy openAlphaTy openBetaTy + (mkVisFunTyMany fun_ty fun_ty) + fun_ty = mkVisFunTyMany openAlphaTy openBetaTy [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] x' = setOneShotLambda x -- Here is the magic bit! rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar @@ -1469,8 +1526,8 @@ coerceId = pcMiscPrelId coerceName ty info , Bndr av SpecifiedSpec , Bndr bv SpecifiedSpec ] $ - mkInvisFunTy eqRTy $ - mkVisFunTy a b + mkInvisFunTyMany eqRTy $ + mkVisFunTyMany a b bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy (\r -> [tYPE r, tYPE r]) @@ -1479,7 +1536,7 @@ coerceId = pcMiscPrelId coerceName ty info [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] rhs = mkLams (bndrs ++ [eqR, x]) $ - mkWildCase (Var eqR) eqRTy b $ + mkWildCase (Var eqR) (unrestricted eqRTy) b $ [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] {- @@ -1708,7 +1765,7 @@ voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy `setNeverLevPoly` voidPrimTy) voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many voidPrimTy coercionTokenId :: Id -- :: () ~ () coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg" diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs index daa6e20fae..0481e6b520 100644 --- a/compiler/GHC/Types/Name/Env.hs +++ b/compiler/GHC/Types/Name/Env.hs @@ -20,7 +20,7 @@ module GHC.Types.Name.Env ( extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, filterNameEnv, anyNameEnv, - plusNameEnv, plusNameEnv_C, alterNameEnv, + plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv, @@ -106,6 +106,8 @@ extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_CD :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a +plusNameEnv_CD2 :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a delFromNameEnv :: NameEnv a -> Name -> NameEnv a @@ -132,6 +134,8 @@ mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) elemNameEnv x y = elemUFM x y plusNameEnv x y = plusUFM x y plusNameEnv_C f x y = plusUFM_C f x y +plusNameEnv_CD f x d y b = plusUFM_CD f x d y b +plusNameEnv_CD2 f x y = plusUFM_CD2 f x y extendNameEnv_C f x y z = addToUFM_C f x y z mapNameEnv f x = mapUFM f x extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index b883fbb05a..5c99cc697d 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -108,7 +108,7 @@ countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _ = 0 countFunRepArgs n ty - | FunTy _ arg res <- unwrapType ty + | FunTy _ _ arg res <- unwrapType ty = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -120,7 +120,7 @@ countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) go 0 _ = 0 go n ty - | FunTy _ arg res <- unwrapType ty + | FunTy _ _ arg res <- unwrapType ty = length (typePrimRep arg) + go (n - 1) res | otherwise = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 3ab075ecc3..6801489604 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -49,6 +49,7 @@ module GHC.Types.Unique.FM ( plusUFM, plusUFM_C, plusUFM_CD, + plusUFM_CD2, plusMaybeUFM_C, plusUFMList, minusUFM, @@ -202,12 +203,12 @@ plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) -- == {A: f 1 42, B: f 2 3, C: f 23 4 } -- @ plusUFM_CD - :: (elt -> elt -> elt) - -> UniqFM elt -- map X - -> elt -- default for X - -> UniqFM elt -- map Y - -> elt -- default for Y - -> UniqFM elt + :: (elta -> eltb -> eltc) + -> UniqFM elta -- map X + -> elta -- default for X + -> UniqFM eltb -- map Y + -> eltb -- default for Y + -> UniqFM eltc plusUFM_CD f (UFM xm) dx (UFM ym) dy = UFM $ M.mergeWithKey (\_ x y -> Just (x `f` y)) @@ -215,6 +216,25 @@ plusUFM_CD f (UFM xm) dx (UFM ym) dy (M.map (\y -> dx `f` y)) xm ym +-- | `plusUFM_CD2 f m1 m2` merges the maps using `f` as the combining +-- function. Unlike `plusUFM_CD`, a missing value is not defaulted: it is +-- instead passed as `Nothing` to `f`. `f` can never have both its arguments +-- be `Nothing`. +-- +-- `plusUFM_CD2 f m1 m2` is the same as `plusUFM_CD f (mapUFM Just m1) Nothing +-- (mapUFM Just m2) Nothing`. +plusUFM_CD2 + :: (Maybe elta -> Maybe eltb -> eltc) + -> UniqFM elta -- map X + -> UniqFM eltb -- map Y + -> UniqFM eltc +plusUFM_CD2 f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> Just (Just x `f` Just y)) + (M.map (\x -> Just x `f` Nothing)) + (M.map (\y -> Nothing `f` Just y)) + xm ym + plusMaybeUFM_C :: (elt -> elt -> Maybe elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt plusMaybeUFM_C f (UFM xm) (UFM ym) diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index a3974a92bd..dfc9cfc0dd 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -45,10 +45,14 @@ module GHC.Types.Var ( -- ** Taking 'Var's apart varName, varUnique, varType, + varMult, varMultMaybe, + varScaledType, -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, updateVarType, - updateVarTypeM, + setVarName, setVarUnique, setVarType, + scaleVarBy, setVarMult, + updateVarTypeButNotMult, + updateVarTypeAndMult, updateVarTypeAndMultM, -- ** Constructing, taking apart, modifying 'Id's mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, @@ -98,6 +102,7 @@ import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) +import GHC.Core.Multiplicity import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique @@ -248,6 +253,7 @@ data Var varName :: !Name, realUnique :: {-# UNPACK #-} !Int, varType :: Type, + varMult :: Mult, -- See Note [Multiplicity of let binders] idScope :: IdScope, id_details :: IdDetails, -- Stable, doesn't change id_info :: IdInfo } -- Unstable, updated by simplifier @@ -298,6 +304,18 @@ A LocalId is * always treated as a candidate by the free-variable finder After CoreTidy, top-level LocalIds are turned into GlobalIds + +Note [Multiplicity of let binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, let-binders' multiplicity is always completely determined by syntax: +a recursive let will always have multiplicity Many (it's a prerequisite for +being recursive), and non-recursive let doesn't have a conventional multiplicity, +instead they act, for the purpose of multiplicity, as an alias for their +right-hand side. + +Therefore, the `varMult` field of identifier is only used by binders in lambda +and case expressions. In a let expression the `varMult` field holds an +arbitrary value which will (and must!) be ignored. -} instance Outputable Var where @@ -321,7 +339,8 @@ instance Outputable Var where _ -> empty in if | debug && (not supp_var_kinds) - -> parens (ppr (varName var) <+> ppr_var <+> + -> parens (ppr (varName var) <+> ppr (varMultMaybe var) + <+> ppr_var <+> dcolon <+> pprKind (tyVarKind var)) | otherwise -> ppr (varName var) <> ppr_var @@ -379,12 +398,39 @@ setVarName var new_name setVarType :: Id -> Type -> Id setVarType id ty = id { varType = ty } -updateVarType :: (Type -> Type) -> Id -> Id -updateVarType f id = id { varType = f (varType id) } +updateVarTypeButNotMult :: (Type -> Type) -> Id -> Id +updateVarTypeButNotMult f id = id { varType = f (varType id) } + +updateVarTypeAndMult :: (Type -> Type) -> Id -> Id +updateVarTypeAndMult f id = let id' = id { varType = f (varType id) } + in case varMultMaybe id' of + Just w -> setVarMult id' (f w) + Nothing -> id' + +updateVarTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id +updateVarTypeAndMultM f id = do { ty' <- f (varType id) + ; let id' = setVarType id ty' + ; case varMultMaybe id of + Just w -> do w' <- f w + return $ setVarMult id' w' + Nothing -> return id' + } + +varMultMaybe :: Id -> Maybe Mult +varMultMaybe (Id { varMult = mult }) = Just mult +varMultMaybe _ = Nothing + +varScaledType :: Id -> Scaled Kind +varScaledType var = Scaled (varMult var) (varType var) + +scaleVarBy :: Mult -> Id -> Id +scaleVarBy m id@(Id { varMult = w }) = + id { varMult = m `mkMultMul` w } +scaleVarBy _ id = id -updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id -updateVarTypeM f id = do { ty' <- f (varType id) - ; return (id { varType = ty' }) } +setVarMult :: Id -> Mult -> Id +setVarMult id r | isId id = id { varMult = r } + | otherwise = pprPanic "setVarMult" (ppr id <+> ppr r) {- ********************************************************************* * * @@ -720,25 +766,29 @@ idDetails other = pprPanic "idDetails" (ppr other) -- Ids, because "GHC.Types.Id" uses 'mkGlobalId' etc with different types mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkGlobalVar details name ty info - = mk_id name ty GlobalId details info + = mk_id name Many ty GlobalId details info + -- There is no support for linear global variables yet. They would require + -- being checked at link-time, which can be useful, but is not a priority. -mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkLocalVar details name ty info - = mk_id name ty (LocalId NotExported) details info +mkLocalVar :: IdDetails -> Name -> Mult -> Type -> IdInfo -> Id +mkLocalVar details name w ty info + = mk_id name w ty (LocalId NotExported) details info mkCoVar :: Name -> Type -> CoVar -- Coercion variables have no IdInfo -mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo +mkCoVar name ty = mk_id name Many ty (LocalId NotExported) coVarDetails vanillaIdInfo -- | Exported 'Var's will not be removed as dead code mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkExportedLocalVar details name ty info - = mk_id name ty (LocalId Exported) details info + = mk_id name Many ty (LocalId Exported) details info + -- There is no support for exporting linear variables. See also [mkGlobalVar] -mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name ty scope details info +mk_id :: Name -> Mult -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name w ty scope details info = Id { varName = name, realUnique = getKey (nameUnique name), + varMult = w, varType = ty, idScope = scope, id_details = details, diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 0514870cea..809c06b64d 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -28,8 +28,8 @@ module GHC.Utils.Outputable ( parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, - arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow, blankLine, forAllLit, bullet, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, @@ -357,6 +357,7 @@ data SDocContext = SDC , sdocSuppressStgExts :: !Bool , sdocErrorSpans :: !Bool , sdocStarIsType :: !Bool + , sdocLinearTypes :: !Bool , sdocImpredicativeTypes :: !Bool , sdocDynFlags :: DynFlags -- TODO: remove } @@ -644,12 +645,13 @@ quotes d = sdocOption sdocCanUseUnicode $ \case _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc blankLine = docToSDoc $ Pretty.text "" dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") +lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "#->") larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") @@ -671,6 +673,10 @@ rbrack = docToSDoc $ Pretty.rbrack lbrace = docToSDoc $ Pretty.lbrace rbrace = docToSDoc $ Pretty.rbrace +mulArrow :: SDoc -> SDoc +mulArrow d = text "#" <+> d <+> arrow + + forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 40c4c609d6..9ef9245a9a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -533,6 +533,8 @@ Library GHC.Core.FamInstEnv GHC.Tc.Instance.FunDeps GHC.Core.InstEnv + GHC.Core.Multiplicity + GHC.Core.UsageEnv GHC.Core.TyCon GHC.Core.Coercion.Axiom GHC.Core.Type diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst index a66ab06514..c729a8ec6c 100644 --- a/docs/users_guide/8.12.1-notes.rst +++ b/docs/users_guide/8.12.1-notes.rst @@ -10,6 +10,15 @@ following sections. Highlights ---------- +* The :extension:`LinearTypes` extension enables linear function syntax + ``a #-> b``, as described in the `Linear Types GHC proposal + <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst>`__. + + The GADT syntax can be used to define data types with linear and nonlinear fields. + + This extension is considered experimental: it doesn't implement the full proposal yet and the details + are subject to change. + * NCG - The linear register allocator saw improvements reducing the number diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index c777ccc25c..4b86617093 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -837,6 +837,16 @@ Checking for consistency Turn on heavyweight intra-pass sanity-checking within GHC, at Core level. (It checks GHC's sanity, not yours.) +.. ghc-flag:: -dlinear-core-lint + :shortdesc: Turn on internal sanity checking + :type: dynamic + + Turn on linearity checking in GHC. Currently, some optimizations + in GHC might not preserve linearity and they valid programs might + fail Linear Core Lint. + In the near future, this option will be removed and folded into + normal Core Lint. + .. ghc-flag:: -dstg-lint :shortdesc: STG pass sanity checking :type: dynamic diff --git a/docs/users_guide/exts/levity_polymorphism.rst b/docs/users_guide/exts/levity_polymorphism.rst index d7954915a0..a65f878b41 100644 --- a/docs/users_guide/exts/levity_polymorphism.rst +++ b/docs/users_guide/exts/levity_polymorphism.rst @@ -89,6 +89,8 @@ These functions do not bind a levity-polymorphic variable, and so are accepted. Their polymorphism allows users to use these to conveniently stub out functions that return unboxed types. +.. _printing-levity-polymorphic-types: + Printing levity-polymorphic types --------------------------------- diff --git a/docs/users_guide/exts/linear_types.rst b/docs/users_guide/exts/linear_types.rst new file mode 100644 index 0000000000..1b725f36cc --- /dev/null +++ b/docs/users_guide/exts/linear_types.rst @@ -0,0 +1,196 @@ +Linear types +============ + +.. extension:: LinearTypes + :shortdesc: Enable linear types. + + :since: 8.12.1 + + Enable the linear arrow ``a #-> b`` and the multiplicity-polymorphic arrow + ``a # m -> b``. + +**This extension is currently considered experimental, expect bugs, +warts, and bad error messages; everything down to the syntax is +subject to change**. See, in particular, +:ref:`linear-types-limitations` below. We encourage you to experiment +with this extension and report issues in the GHC bug tracker `the GHC +bug tracker <https://gitlab.haskell.org/ghc/ghc/issues>`__, adding the +tag ``LinearTypes``. + +A function ``f`` is linear if: when its result is consumed *exactly +once*, then its argument is consumed *exactly once*. Intuitively, it +means that in every branch of the definition of ``f``, its argument +``x`` must be used exactly once. Which can be done by + +* Returning ``x`` unmodified +* Passing ``x`` to a *linear* function +* Pattern-matching on ``x`` and using each argument exactly once in the + same fashion. +* Calling it as a function and using the result exactly once in the same + fashion. + +With ``-XLinearTypes``, you can write ``f :: a #-> b`` to mean that +``f`` is a linear function from ``a`` to ``b``. If +:extension:`UnicodeSyntax` is enabled, the ``#->`` arrow can be +written as ``⊸``. + +To allow uniform handling of linear ``a #-> b`` and unrestricted ``a +-> b`` functions, there is a new function type ``a # m -> b``. This +syntax is, however, not implemented yet, see +:ref:`linear-types-limitations`. Here, ``m`` is a type of new kind +``Multiplicity``. We have: + +:: + + data Multiplicity = One | Many -- Defined in GHC.Types + + type a #-> b = a # 'One -> b + type a -> b = a # 'Many -> b + +(See :ref:`promotion`). + +We say that a variable whose multiplicity constraint is ``Many`` is +*unrestricted*. + +The multiplicity-polymorphic arrow ``a # m -> b`` is available in a prefix +version as ``GHC.Exts.FUN m a b``, which can be applied +partially. See, however :ref:`linear-types-limitations`. + +Linear and multiplicity-polymorphic arrows are *always declared*, +never inferred. That is, if you don't give an appropriate type +signature to a function, it will be inferred as being a regular +function of type ``a -> b``. + +Data types +---------- +By default, all fields in algebraic data types are linear (even if +``-XLinearTypes`` is not turned on). Given + +:: + + data T1 a = MkT1 a + +the value ``MkT1 x`` can be constructed and deconstructed in a linear context: + +:: + + construct :: a #-> MkT1 a + construct x = MkT1 x + + deconstruct :: MkT1 a #-> a + deconstruct (MkT1 x) = x -- must consume `x` exactly once + +When used as a value, ``MkT1`` is given a multiplicity-polymorphic +type: ``MkT1 :: forall {m} a. a # m -> T1 a``. This makes it possible +to use ``MkT1`` in higher order functions. The additional multiplicity +argument ``m`` is marked as inferred (see +:ref:`inferred-vs-specified`), so that there is no conflict with +visible type application. When displaying types, unless +``-XLinearTypes`` is enabled, multiplicity polymorphic functions are +printed as regular functions (see :ref:`printing-linear-types`); +therefore constructors appear to have regular function types. + +:: + + mkList :: [a] -> [MkT1 a] + mkList xs = map MkT1 xs + +Hence the linearity of type constructors is invisible when +``-XLinearTypes`` is off. + +Whether a data constructor field is linear or not can be customized using the GADT syntax. Given + +:: + + data T2 a b c where + MkT2 :: a -> b #-> c #-> T2 a b -- Note unrestricted arrow in the first argument + +the value ``MkT2 x y z`` can be constructed only if ``x`` is +unrestricted. On the other hand, a linear function which is matching +on ``MkT2 x y z`` must consume ``y`` and ``z`` exactly once, but there +is no restriction on ``x``. + +If :extension:`LinearTypes` is disabled, all fields are considered to be linear +fields, including GADT fields defined with the ``->`` arrow. + +In a ``newtype`` declaration, the field must be linear. Attempting to +write an unrestricted newtype constructor with GADT syntax results in +an error. + +.. _printing-linear-types: + +Printing multiplicity-polymorphic types +--------------------------------------- +If :extension:`LinearTypes` is disabled, multiplicity variables in types are defaulted +to ``Many`` when printing, in the same manner as described in :ref:`printing-levity-polymorphic-types`. +In other words, without :extension:`LinearTypes`, multiplicity-polymorphic functions +``a # m -> b`` are printed as normal Haskell2010 functions ``a -> b``. This allows +existing libraries to be generalized to linear types in a backwards-compatible +manner; the general types are visible only if the user has enabled +:extension:`LinearTypes`. +(Note that a library can declare a linear function in the contravariant position, +i.e. take a linear function as an argument. In this case, linearity cannot be +hidden; it is an essential part of the exposed interface.) + +.. _linear-types-limitations: + +Limitations +----------- +Linear types are still considered experimental and come with several +limitations. If you have read the full design in the proposal (see +:ref:`linear-types-references` below), here is a run down of the +missing pieces. + +- The syntax ``a # p -> b`` is not yet implemented. You can use ``GHC.Exts.FUN + p a b`` instead. However, be aware of the next point. +- Multiplicity polymorphism is incomplete and experimental. You may + have success using it, or you may not. Expect it to be really unreliable. +- There is currently no support for multiplicity annotations such as + ``x :: a # p``, ``\(x :: a # p) -> ...``. +- All ``case``, ``let`` and ``where`` statements consume their + right-hand side, or scrutiny, ``Many`` times. That is, the following + will not type check: + + :: + + g :: A #-> (A, B) + h :: A #-> B #-> C + + f :: A #-> C + f x = + case g x of + (y, z) -> h y z + + This can be worked around by defining extra functions which are + specified to be linear, such as: + + :: + + g :: A #-> (A, B) + h :: A #-> B #-> C + + f :: A #-> C + f x = f' (g x) + where + f' :: (A, B) #-> C + f' (y, z) = h y z +- There is no support for linear pattern synonyms. +- ``@``-patterns and view patterns are not linear. +- The projection function for a record with a single linear field should be + multiplicity-polymorphic; currently it's unrestricted. +- Attempting to use of linear types in Template Haskell will probably + not work. + +.. _linear-types-references: + +Design and further reading +-------------------------- + +* The design for this extension is described in details in the `Linear + types proposal + <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst>`__ +* This extension has been originally conceived of in the paper `Linear + Haskell: practical linearity in a higher-order polymorphic language + <https://www.microsoft.com/en-us/research/publication/linear-haskell-practical-linearity-higher-order-polymorphic-language/>`__ + (POPL 2018) +* There is a `wiki page dedicated to the linear types extension <https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types>`__ diff --git a/docs/users_guide/exts/types.rst b/docs/users_guide/exts/types.rst index f5fd5d130e..2cd9d059f5 100644 --- a/docs/users_guide/exts/types.rst +++ b/docs/users_guide/exts/types.rst @@ -22,6 +22,7 @@ Types type_applications rank_polymorphism impredicative_types + linear_types type_errors defer_type_errors roles diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 363d959598..2a7f385830 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1676,7 +1676,7 @@ defineMacro overwrite s = do ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) `mkHsApp` (nlHsPar expr) - tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) + tySig = mkLHsSigWcType (nlHsFunTy HsUnrestrictedArrow stringTy ioM) new_expr = L (getLoc expr) $ ExprWithTySig noExtField body tySig hv <- GHC.compileParsedExprRemote new_expr @@ -1744,7 +1744,7 @@ getGhciStepIO = do ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) - tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM) + tySig = mkLHsSigWcType (nlHsFunTy HsUnrestrictedArrow ghciM ioM) return $ noLoc $ ExprWithTySig noExtField body tySig ----------------------------------------------------------------------------- diff --git a/libraries/base/Data/Kind.hs b/libraries/base/Data/Kind.hs index 9ee7b7ab07..094bc4efae 100644 --- a/libraries/base/Data/Kind.hs +++ b/libraries/base/Data/Kind.hs @@ -14,6 +14,7 @@ -- @since 4.9.0.0 ----------------------------------------------------------------------------- -module Data.Kind ( Type, Constraint ) where +module Data.Kind ( Type, Constraint, FUN ) where +import GHC.Prim import GHC.Types diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 274efb8ade..7ac590a829 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -19,6 +19,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE LinearTypes #-} ----------------------------------------------------------------------------- -- | @@ -81,9 +82,10 @@ module Data.Typeable.Internal ( typeSymbolTypeRep, typeNatTypeRep, ) where +import GHC.Prim ( FUN ) import GHC.Base import qualified GHC.Arr as A -import GHC.Types ( TYPE ) +import GHC.Types ( TYPE, Multiplicity (Many) ) import Data.Type.Equality import GHC.List ( splitAt, foldl', elem ) import GHC.Word @@ -209,18 +211,19 @@ data TypeRep a where , trAppKind :: !(TypeRep k2) } -- See Note [Kind caching] -> TypeRep (a b) - -- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for + -- | @TrFun fpr m a b@ represents a function type @a # m -> b@. We use this for -- the sake of efficiency as functions are quite ubiquitous. - TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + TrFun :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). { -- See Note [TypeRep fingerprints] trFunFingerprint :: {-# UNPACK #-} !Fingerprint -- The TypeRep represents a function from trFunArg to -- trFunRes. + , trFunMul :: !(TypeRep m) , trFunArg :: !(TypeRep a) , trFunRes :: !(TypeRep b) } - -> TypeRep (a -> b) + -> TypeRep (FUN m a b) {- Note [TypeRep fingerprints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -308,7 +311,7 @@ instance Ord (TypeRep a) where -- | A non-indexed type representation. data SomeTypeRep where - SomeTypeRep :: forall k (a :: k). !(TypeRep a) -> SomeTypeRep + SomeTypeRep :: forall k (a :: k). !(TypeRep a) #-> SomeTypeRep instance Eq SomeTypeRep where SomeTypeRep a == SomeTypeRep b = @@ -335,8 +338,8 @@ pattern Fun :: forall k (fun :: k). () => TypeRep arg -> TypeRep res -> TypeRep fun -pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res} - where Fun arg res = mkTrFun arg res +pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res, trFunMul = (eqTypeRep trMany -> Just HRefl)} + where Fun arg res = mkTrFun trMany arg res -- | Observe the 'Fingerprint' of a type representation -- @@ -383,6 +386,9 @@ trTYPE = typeRep trLiftedRep :: TypeRep 'LiftedRep trLiftedRep = typeRep +trMany :: TypeRep 'Many +trMany = typeRep + -- | Construct a representation for a type application that is -- NOT a saturated arrow type. This is not checked! @@ -426,7 +432,7 @@ mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x}) , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y) , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep - = mkTrFun x y + = mkTrFun trMany x y mkTrAppChecked a b = mkTrApp a b -- | A type application. @@ -455,9 +461,9 @@ pattern App f x <- (splitApp -> IsApp f x) data AppOrCon (a :: k) where IsApp :: forall k k' (f :: k' -> k) (x :: k'). () - => TypeRep f -> TypeRep x -> AppOrCon (f x) + => TypeRep f #-> TypeRep x #-> AppOrCon (f x) -- See Note [Con evidence] - IsCon :: IsApplication a ~ "" => TyCon -> [SomeTypeRep] -> AppOrCon a + IsCon :: IsApplication a ~ "" => TyCon #-> [SomeTypeRep] #-> AppOrCon a type family IsApplication (x :: k) :: Symbol where IsApplication (_ _) = "An error message about this unifying with \"\" " @@ -616,7 +622,7 @@ instantiateKindRep vars = go go (KindRepApp f a) = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a) go (KindRepFun a b) - = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) + = SomeTypeRep $ mkTrFun trMany (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) go (KindRepTYPE LiftedRep) = SomeTypeRep TrType go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r go (KindRepTypeLitS sort s) @@ -634,7 +640,7 @@ unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x data SomeKindedTypeRep k where SomeKindedTypeRep :: forall k (a :: k). TypeRep a - -> SomeKindedTypeRep k + #-> SomeKindedTypeRep k kApp :: SomeKindedTypeRep (k -> k') -> SomeKindedTypeRep k @@ -712,19 +718,19 @@ vecElemTypeRep e = rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem rep = kindedTypeRep @VecElem @a -bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) +bareArrow :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). () - => TypeRep (a -> b) - -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type) -bareArrow (TrFun _ a b) = - mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2] + => TypeRep (FUN m a b) + -> TypeRep (FUN m :: TYPE r1 -> TYPE r2 -> Type) +bareArrow (TrFun _ m a b) = + mkTrCon funTyCon [SomeTypeRep m, SomeTypeRep rep1, SomeTypeRep rep2] where rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1 rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2 bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible" data IsTYPE (a :: Type) where - IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r) + IsTYPE :: forall (r :: RuntimeRep). TypeRep r #-> IsTYPE (TYPE r) -- | Is a type of the form @TYPE rep@? isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a) @@ -816,8 +822,9 @@ splitApps = go [] = (tc, xs) go xs (TrApp {trAppFun = f, trAppArg = x}) = go (SomeTypeRep x : xs) f - go [] (TrFun {trFunArg = a, trFunRes = b}) - = (funTyCon, [SomeTypeRep a, SomeTypeRep b]) + go [] (TrFun {trFunArg = a, trFunRes = b, trFunMul = mul}) + | Just HRefl <- eqTypeRep trMany mul = (funTyCon, [SomeTypeRep a, SomeTypeRep b]) + | otherwise = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Only unrestricted functions are supported" go _ (TrFun {}) = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1" go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep]) @@ -997,14 +1004,16 @@ typeLitTypeRep :: forall k (a :: k). (Typeable k) => typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) [] -- | For compiler use. -mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) +mkTrFun :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). - TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type) -mkTrFun arg res = TrFun + TypeRep m -> TypeRep a -> TypeRep b -> TypeRep ((FUN m a b) :: Type) +mkTrFun mul arg res = TrFun { trFunFingerprint = fpr + , trFunMul = mul , trFunArg = arg , trFunRes = res } - where fpr = fingerprintFingerprints [ typeRepFingerprint arg + where fpr = fingerprintFingerprints [ typeRepFingerprint mul + , typeRepFingerprint arg , typeRepFingerprint res] {- $kind_instantiation diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index de66508fcb..f6d7c43ca9 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -30,6 +30,7 @@ module GHC.Exts maxTupleSize, -- * Primitive operations + FUN, -- See https://gitlab.haskell.org/ghc/ghc/issues/18302 module GHC.Prim, module GHC.Prim.Ext, shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#, diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs index 1bc4cac1ea..e4021ee115 100644 --- a/libraries/base/GHC/Ptr.hs +++ b/libraries/base/GHC/Ptr.hs @@ -93,9 +93,7 @@ minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2) ------------------------------------------------------------------------ -- Function pointers for the default calling convention. --- 'FunPtr' has a phantom role for similar reasons to 'Ptr'. Note --- that 'FunPtr's role cannot become nominal without changes elsewhere --- in GHC. See Note [FFI type roles] in GHC.Tc.Gen.Foreign. +-- 'FunPtr' has a phantom role for similar reasons to 'Ptr'. type role FunPtr phantom data FunPtr a = FunPtr Addr# deriving (Eq, Ord) -- ^ A value of type @'FunPtr' a@ is a pointer to a function callable diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 33573f62b7..b7c3ba3a1a 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -73,6 +73,7 @@ data Extension | DataKinds -- Datatype promotion | InstanceSigs | ApplicativeDo + | LinearTypes | StandaloneDeriving | DeriveDataTypeable diff --git a/libraries/ghc-prim/GHC/CString.hs b/libraries/ghc-prim/GHC/CString.hs index ad89a5d3e3..1edeecbbfa 100644 --- a/libraries/ghc-prim/GHC/CString.hs +++ b/libraries/ghc-prim/GHC/CString.hs @@ -27,7 +27,7 @@ module GHC.CString ( unpackNBytes#, ) where -import GHC.Types +import GHC.Types hiding (One) import GHC.Prim {- diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 0a32454149..ea36868e2d 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples, MultiParamTypeClasses, RoleAnnotations, CPP, TypeOperators, - PolyKinds #-} + PolyKinds, NegativeLiterals, DataKinds #-} +-- NegativeLiterals: see Note [Fixity of (->)] ----------------------------------------------------------------------------- -- | -- Module : GHC.Types @@ -40,13 +41,40 @@ module GHC.Types ( -- * Runtime type representation Module(..), TrName(..), TyCon(..), TypeLitSort(..), - KindRep(..), KindBndr + KindRep(..), KindBndr, + + -- * Multiplicity Types + Multiplicity(..), MultMul ) where import GHC.Prim infixr 5 : + +{- ********************************************************************* +* * + Functions +* * +********************************************************************* -} + +infixr -1 -> +{- +Note [Fixity of (->)] +~~~~~~~~~~~~~~~~~~~~~ +This declaration is important for :info (->) command (issue #10145) +1) The parser parses -> as if it had lower fixity than 0, + so we conventionally use -1 (issue #15235). +2) Fixities outside the 0-9 range are exceptionally allowed + for (->) (see checkPrecP in RdrHsSyn) +3) The negative fixity -1 must be parsed as a single token, + hence this module requires NegativeLiterals. +-} + +-- | The regular function type +type (->) = FUN 'Many +-- See Note [Linear Types] in Multiplicity + {- ********************************************************************* * * Kinds @@ -59,6 +87,14 @@ data Constraint -- | The kind of types with lifted values. For example @Int :: Type@. type Type = TYPE 'LiftedRep +data Multiplicity = Many | One + +type family MultMul (a :: Multiplicity) (b :: Multiplicity) :: Multiplicity where + MultMul 'One x = x + MultMul x 'One = x + MultMul 'Many x = 'Many + MultMul x 'Many = 'Many + {- ********************************************************************* * * Nat and Symbol @@ -185,13 +221,6 @@ or the 'Prelude.>>' and 'Prelude.>>=' operations from the 'Prelude.Monad' class. -} newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) -type role IO representational - -{- The 'type role' role annotation for IO is redundant but is included -because this role is significant in the normalisation of FFI -types. Specifically, if this role were to become nominal (which would -be very strange, indeed!), changes elsewhere in GHC would be -necessary. See [FFI type roles] in GHC.Tc.Gen.Foreign. -} {- ********************************************************************* diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 4df23cd3c5..4c4eaf5dbe 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -56,6 +56,7 @@ module Language.Haskell.TH.Lib ( -- *** Types forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT, + mulArrowT, uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index e5899dacb8..ff020ee62d 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -694,6 +694,9 @@ appKindT ty ki = do arrowT :: Quote m => m Type arrowT = pure ArrowT +mulArrowT :: Quote m => m Type +mulArrowT = pure MulArrowT + listT :: Quote m => m Type listT = pure ListT diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 6dd90e364b..fcaaa40c3e 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -756,6 +756,7 @@ pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar pprParendType ArrowT = parens (text "->") +pprParendType MulArrowT = text "FUN" pprParendType ListT = text "[]" pprParendType (LitT l) = pprTyLit l pprParendType (PromotedT c) = text "'" <> pprName' Applied c @@ -812,6 +813,11 @@ parens around it. E.g. the parens are required here: So we always print a SigT with parens (see #10050). -} pprTyApp :: (Type, [TypeArg]) -> Doc +pprTyApp (MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2]) + | c == oneName = sep [pprFunArgType arg1 <+> text "#->", ppr arg2] + | c == manyName = sep [pprFunArgType arg1 <+> text "->", ppr arg2] +pprTyApp (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) = + sep [pprFunArgType arg1 <+> text "#" <+> ppr argm <+> text "->", ppr arg2] pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "~", ppr arg2] @@ -834,6 +840,7 @@ pprFunArgType :: Type -> Doc -- Should really use a precedence argument -- Everything except forall and (->) binds more tightly than (->) pprFunArgType ty@(ForallT {}) = parens (ppr ty) pprFunArgType ty@(ForallVisT {}) = parens (ppr ty) +pprFunArgType ty@(((MulArrowT `AppT` _) `AppT` _) `AppT` _) = parens (ppr ty) pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) pprFunArgType ty@(SigT _ _) = parens (ppr ty) pprFunArgType ty = ppr ty diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index b1b40c7951..955f430d33 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1095,6 +1095,9 @@ rightName = mkNameG DataName "base" "Data.Either" "Right" nonemptyName :: Name nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" +oneName, manyName :: Name +oneName = mkNameG DataName "ghc-prim" "GHC.Types" "One" +manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many" ----------------------------------------------------- -- -- Generic Lift implementations @@ -2465,6 +2468,7 @@ data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ct | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ | ArrowT -- ^ @->@ + | MulArrowT -- ^ @FUN@ | EqualityT -- ^ @~@ | ListT -- ^ @[]@ | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 60cb97835f..55427ff4b7 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, PatternSynonyms #-} import GHC.Core import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core.Make import GHC.Core.Opt.CallArity (callArityRHS) import GHC.Types.Id.Make @@ -27,16 +28,16 @@ import GHC.Data.FastString go, go2, x, d, n, y, z, scrutf, scruta :: Id [go, go2, x,d, n, y, z, scrutf, scruta, f] = mkTestIds (words "go go2 x d n y z scrutf scruta f") - [ mkVisFunTys [intTy, intTy] intTy - , mkVisFunTys [intTy, intTy] intTy + [ mkVisFunTysMany [intTy, intTy] intTy + , mkVisFunTysMany [intTy, intTy] intTy , intTy - , mkVisFunTys [intTy] intTy - , mkVisFunTys [intTy] intTy + , mkVisFunTysMany [intTy] intTy + , mkVisFunTysMany [intTy] intTy , intTy , intTy - , mkVisFunTys [boolTy] boolTy + , mkVisFunTysMany [boolTy] boolTy , boolTy - , mkVisFunTys [intTy, intTy] intTy -- protoypical external function + , mkVisFunTysMany [intTy, intTy] intTy -- protoypical external function ] exprs :: [(String, CoreExpr)] @@ -188,7 +189,7 @@ mkLApps v = mkApps (Var v) . map mkLit mkACase = mkIfThenElse (mkVarApps (Var scrutf) [scruta]) mkTestId :: Int -> String -> Type -> Id -mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty +mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) Many ty mkTestIds :: [String] -> [Type] -> [Id] mkTestIds ns tys = zipWith3 mkTestId [0..] ns tys diff --git a/testsuite/tests/codeGen/should_compile/T13233.hs b/testsuite/tests/codeGen/should_compile/T13233.hs new file mode 100644 index 0000000000..bb79856d3b --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T13233.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +module Bug where + +import GHC.Exts (TYPE) + +class Foo (a :: TYPE rep) where + bar :: forall (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b + +baz :: forall (a :: TYPE rep). Foo a => a -> a -> (# a, a #) +baz = bar (#,#) diff --git a/testsuite/tests/codeGen/should_fail/T13233.hs b/testsuite/tests/codeGen/should_fail/T13233.hs index f24fc03bfb..42a30522f2 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.hs +++ b/testsuite/tests/codeGen/should_fail/T13233.hs @@ -3,19 +3,20 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE LinearTypes #-} module Bug where import GHC.Exts (TYPE, RuntimeRep, Weak#, State#, RealWorld, mkWeak# ) class Foo (a :: TYPE rep) where - bar :: forall rep2 (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b + bar :: forall rep2 (b :: TYPE rep2). (a #-> a #-> b) -> a #-> a #-> b -baz :: forall rep (a :: TYPE rep). Foo a => a -> a -> (# a, a #) +baz :: forall rep (a :: TYPE rep). Foo a => a #-> a #-> (# a, a #) baz = bar (#,#) obscure :: (forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep) (a :: TYPE rep1) (b :: TYPE rep2). - a -> b -> (# a, b #)) -> () + a #-> b #-> (# a, b #)) -> () obscure _ = () quux :: () diff --git a/testsuite/tests/codeGen/should_fail/T13233.stderr b/testsuite/tests/codeGen/should_fail/T13233.stderr index f6254778c1..1bbe161967 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.stderr +++ b/testsuite/tests/codeGen/should_fail/T13233.stderr @@ -1,27 +1,11 @@ -T13233.hs:14:11: error: - Cannot use function with levity-polymorphic arguments: - (#,#) :: a -> a -> (# a, a #) - (Note that levity-polymorphic primops such as 'coerce' and unboxed tuples - are eta-expanded internally because they must occur fully saturated. - Use -fprint-typechecker-elaboration to display the full expression.) - Levity-polymorphic arguments: - a :: TYPE rep - a :: TYPE rep - -T13233.hs:22:16: error: - Cannot use function with levity-polymorphic arguments: - (#,#) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep} - {a :: TYPE rep1} {b :: TYPE rep2}. - a -> b -> (# a, b #) - (Note that levity-polymorphic primops such as 'coerce' and unboxed tuples - are eta-expanded internally because they must occur fully saturated. - Use -fprint-typechecker-elaboration to display the full expression.) - Levity-polymorphic arguments: - a :: TYPE rep1 - b :: TYPE rep2 +T13233.hs:23:16: error: + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE rep1 + When trying to create a variable of type: a -T13233.hs:27:10: error: +T13233.hs:28:10: error: Cannot use function with levity-polymorphic arguments: mkWeak# :: a -> b diff --git a/testsuite/tests/codeGen/should_fail/T13233_elab.stderr b/testsuite/tests/codeGen/should_fail/T13233_elab.stderr index 40a12ecd62..6a069752f7 100644 --- a/testsuite/tests/codeGen/should_fail/T13233_elab.stderr +++ b/testsuite/tests/codeGen/should_fail/T13233_elab.stderr @@ -1,25 +1,11 @@ -T13233_elab.hs:17:11: error: - Cannot use function with levity-polymorphic arguments: - (#,#) @rep @rep @a @a :: a -> a -> (# a, a #) - Levity-polymorphic arguments: - a :: TYPE rep - a :: TYPE rep - T13233_elab.hs:25:16: error: - Cannot use function with levity-polymorphic arguments: - /\(@(rep1 :: RuntimeRep)). - /\(@(rep2 :: RuntimeRep)). - /\(@(a :: TYPE rep1)). - /\(@(b :: TYPE rep2)). - (#,#) @rep1 @rep2 @a @b :: forall {rep1 :: RuntimeRep} - {rep2 :: RuntimeRep} {a :: TYPE rep1} {b :: TYPE rep2}. - a -> b -> (# a, b #) - Levity-polymorphic arguments: - a :: TYPE rep1 - b :: TYPE rep2 + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE rep1 + When trying to create a variable of type: a -T13233_elab.hs:33:10: +T13233_elab.hs:33:10: error: Cannot use function with levity-polymorphic arguments: mkWeak# @rep @a @b @c :: a -> b diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr index 44af3fd5f7..df2f4977f8 100644 --- a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr +++ b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr @@ -12,4 +12,4 @@ Simplifier ticks exhausted simplifier non-termination has been judged acceptable. To see detailed counts use -ddump-simpl-stats - Total ticks: 136724 + Total ticks: 136962 diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr index 59fc405cdb..2bf9552ff9 100644 --- a/testsuite/tests/deriving/should_compile/T14682.stderr +++ b/testsuite/tests/deriving/should_compile/T14682.stderr @@ -21,8 +21,8 @@ Derived class instances: instance Data.Data.Data T14682.Foo where Data.Data.gfoldl k z (T14682.Foo a1 a2) - = ((z T14682.Foo `k` a1) `k` a2) - Data.Data.gunfold k z _ = k (k (z T14682.Foo)) + = ((z (\ a1 a2 -> T14682.Foo a1 a2) `k` a1) `k` a2) + Data.Data.gunfold k z _ = k (k (z (\ a1 a2 -> T14682.Foo a1 a2))) Data.Data.toConstr (T14682.Foo _ _) = T14682.$cFoo Data.Data.dataTypeOf _ = T14682.$tFoo diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index c83d29b03d..c1c9502863 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -40,6 +40,7 @@ expectedGhcOnlyExtensions = [ "RelaxedLayout" , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" + , "LinearTypes" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stdout b/testsuite/tests/ghci.debugger/scripts/break006.stdout index 407ad3739b..2b4a6c20f8 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break006.stdout @@ -4,14 +4,14 @@ f :: Int -> a = _ x :: Int = 1 xs :: [Int] = [2,3] xs :: [Int] = [2,3] -x :: Int = 1 f :: Int -> a = _ +x :: Int = 1 _result :: [a] = _ y = (_t1::a) y = 2 xs :: [Int] = [2,3] -x :: Int = 1 f :: Int -> Int = _ +x :: Int = 1 _result :: [Int] = _ y :: Int = 2 _t1 :: Int = 2 diff --git a/testsuite/tests/ghci.debugger/scripts/hist001.stdout b/testsuite/tests/ghci.debugger/scripts/hist001.stdout index a19a34f315..b52e8aa5fe 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist001.stdout @@ -20,8 +20,8 @@ _result :: a f :: Integer -> a x :: Integer xs :: [t] = [] -x :: Integer = 2 f :: Integer -> a = _ +x :: Integer = 2 _result :: a = _ _result = 3 Logged breakpoint at Test3.hs:2:18-31 diff --git a/testsuite/tests/ghci.debugger/scripts/hist002.stdout b/testsuite/tests/ghci.debugger/scripts/hist002.stdout index a19a34f315..b52e8aa5fe 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist002.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist002.stdout @@ -20,8 +20,8 @@ _result :: a f :: Integer -> a x :: Integer xs :: [t] = [] -x :: Integer = 2 f :: Integer -> a = _ +x :: Integer = 2 _result :: a = _ _result = 3 Logged breakpoint at Test3.hs:2:18-31 diff --git a/testsuite/tests/ghci/T18060/T18060.stdout b/testsuite/tests/ghci/T18060/T18060.stdout index 9d6ab23dba..8c3a2794fe 100644 --- a/testsuite/tests/ghci/T18060/T18060.stdout +++ b/testsuite/tests/ghci/T18060/T18060.stdout @@ -1,6 +1,6 @@ type (->) :: * -> * -> * -data (->) a b - -- Defined in ‘GHC.Prim’ +type (->) = (->) :: * -> * -> * + -- Defined in ‘GHC.Types’ infixr -1 -> instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout index 7a949cd465..f7e40fd0f4 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -1,6 +1,6 @@ type (->) :: * -> * -> * -data (->) a b - -- Defined in ‘GHC.Prim’ +type (->) = (->) :: * -> * -> * + -- Defined in ‘GHC.Types’ infixr -1 -> instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout index 7a949cd465..f7e40fd0f4 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -1,6 +1,6 @@ type (->) :: * -> * -> * -data (->) a b - -- Defined in ‘GHC.Prim’ +type (->) = (->) :: * -> * -> * + -- Defined in ‘GHC.Types’ infixr -1 -> instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout index 7a949cd465..f7e40fd0f4 100644 --- a/testsuite/tests/ghci/should_run/T10145.stdout +++ b/testsuite/tests/ghci/should_run/T10145.stdout @@ -1,6 +1,6 @@ type (->) :: * -> * -> * -data (->) a b - -- Defined in ‘GHC.Prim’ +type (->) = (->) :: * -> * -> * + -- Defined in ‘GHC.Types’ infixr -1 -> instance Applicative ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/linear/Makefile b/testsuite/tests/linear/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/linear/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/linear/should_compile/Arity2.hs b/testsuite/tests/linear/should_compile/Arity2.hs new file mode 100644 index 0000000000..d764d5111a --- /dev/null +++ b/testsuite/tests/linear/should_compile/Arity2.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Arity2 where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +--import GHC.Base + +data Id a = Id a + +(<$>) :: (a -> b) -> Id a -> Id b +(<$>) f (Id a) = Id (f a) + +(<*>) :: Id (a -> b) -> Id a -> Id b +(<*>) (Id a) (Id b) = Id (a b) + +data Q = Q () () +data S = S () + +-- Q only gets eta-expand once and then trapped +foo = Q <$> Id () <*> Id () + +-- This compiles fine +foo2 = S <$> Id () + +{- +[1 of 1] Compiling Arity2 ( linear-tests/Arity2.hs, linear-tests/Arity2.o ) + +linear-tests/Arity2.hs:21:7: error: + • Couldn't match type ‘() ⊸ Q’ with ‘() -> b’ + Expected type: Id (() -> b) + Actual type: Id (() ⊸ Q) + • In the first argument of ‘(<*>)’, namely ‘Q <$> Id ()’ + In the expression: Q <$> Id () <*> Id () + In an equation for ‘foo’: foo = Q <$> Id () <*> Id () + • Relevant bindings include + foo :: Id b (bound at linear-tests/Arity2.hs:21:1) + | +21 | foo = Q <$> Id () <*> Id () + | ^^^^^^^^^^^ +-} diff --git a/testsuite/tests/linear/should_compile/Branches.hs b/testsuite/tests/linear/should_compile/Branches.hs new file mode 100644 index 0000000000..ee08ade335 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Branches.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +module GuardTup where + +data Q = Q () + +mkQ :: () -> Q +mkQ = Q + +foo smart + | smart = mkQ + | otherwise = Q + +fooIf smart = if smart then mkQ else Q diff --git a/testsuite/tests/linear/should_compile/CSETest.hs b/testsuite/tests/linear/should_compile/CSETest.hs new file mode 100644 index 0000000000..3321dbd43d --- /dev/null +++ b/testsuite/tests/linear/should_compile/CSETest.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} +{- This test makes sure that if two expressions with conflicting types are + CSEd then appropiate things happen. -} +module CSETest where + +minimal :: a ⊸ a +minimal x = x + +maximal :: a -> a +maximal x = x diff --git a/testsuite/tests/linear/should_compile/Dollar2.hs b/testsuite/tests/linear/should_compile/Dollar2.hs new file mode 100644 index 0000000000..4cde3dcb45 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Dollar2.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Dollar2 where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + + +import GHC.Base + +data AB = A () | B () + +qux :: Bool +qux = True +{-# NOINLINE qux #-} + +foo = id $ ((if qux then A else B) $ ()) + +{- + +-} diff --git a/testsuite/tests/linear/should_compile/DollarDefault.hs b/testsuite/tests/linear/should_compile/DollarDefault.hs new file mode 100644 index 0000000000..dbe689566a --- /dev/null +++ b/testsuite/tests/linear/should_compile/DollarDefault.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +module DollarDefault where + +class C p where + cid :: p a a -> p a a + +instance C (->) where + cid = id + +foo = (cid $ id) $ () diff --git a/testsuite/tests/linear/should_compile/DollarTest.hs b/testsuite/tests/linear/should_compile/DollarTest.hs new file mode 100644 index 0000000000..bc15a4fead --- /dev/null +++ b/testsuite/tests/linear/should_compile/DollarTest.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} +module Dollar where +{- +Check $ interacting with multiplicity polymorphism. +This caused Core Lint error previously. +-} + +import GHC.Base + +data Q a = Q a + +data QU = QU () + +test = QU $ () + +qux = Q $ () diff --git a/testsuite/tests/linear/should_compile/Foldr.hs b/testsuite/tests/linear/should_compile/Foldr.hs new file mode 100644 index 0000000000..759256d5b2 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Foldr.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module FoldrExample where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +import GHC.Base +import Data.Maybe + +qux :: [Maybe Char] -> String +qux str = foldr (maybe id (:)) "" str + +{- + +[1 of 1] Compiling FoldrExample ( linear-tests/Foldr.hs, linear-tests/Foldr.o ) + +linear-tests/Foldr.hs:11:27: error: + • Couldn't match type ‘[Char] ⊸ [Char]’ with ‘[Char] -> [Char]’ + Expected type: Char -> [Char] -> [Char] + Actual type: Char ⊸ [Char] ⊸ [Char] + • In the second argument of ‘maybe’, namely ‘(:)’ + In the first argument of ‘foldr’, namely ‘(maybe id (:))’ + In the expression: foldr (maybe id (:)) "" str + | +11 | qux str = foldr (maybe id (:)) "" str + | ^^^ + +-} diff --git a/testsuite/tests/linear/should_compile/Iden.hs b/testsuite/tests/linear/should_compile/Iden.hs new file mode 100644 index 0000000000..3522a43c42 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Iden.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LinearTypes #-} +module Foo where + +newtype HappyIdentity a = HappyIdentity a +happyIdentity = HappyIdentity diff --git a/testsuite/tests/linear/should_compile/Linear10.hs b/testsuite/tests/linear/should_compile/Linear10.hs new file mode 100644 index 0000000000..e76a344fb0 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear10.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +module Linear10 where + +data Unrestricted a where Unrestricted :: a -> Unrestricted a + +unrestrictedDup :: Unrestricted a ⊸ (a, a) +unrestrictedDup (Unrestricted a) = (a,a) diff --git a/testsuite/tests/linear/should_compile/Linear12.hs b/testsuite/tests/linear/should_compile/Linear12.hs new file mode 100644 index 0000000000..3f49e94948 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear12.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +module Linear12 where + +type N a = a ⊸ () + +consume :: a ⊸ N a ⊸ () +consume x k = k x + +data N' a where N :: N a ⊸ N' a + +consume' :: a ⊸ N' a ⊸ () +consume' x (N k) = k x + +data W = W (W ⊸ ()) + +wPlusTwo :: W ⊸ W +wPlusTwo n = W (\(W k) -> k n) + +data Nat = S Nat + +natPlusOne :: Nat ⊸ Nat +natPlusOne n = S n + +data D = D () + +mkD :: () ⊸ D +mkD x = D x + +data Odd = E Even +data Even = O Odd + +evenPlusOne :: Even ⊸ Odd +evenPlusOne e = E e diff --git a/testsuite/tests/linear/should_compile/Linear14.hs b/testsuite/tests/linear/should_compile/Linear14.hs new file mode 100644 index 0000000000..3a40212f75 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear14.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear14 where + +-- Inference-related behaviour. Slightly sub-optimal still. + +bind1 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c +bind1 b x f = b x (\a -> f a) + +newtype I a = I a + +bind2 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (I a⊸b) ⊸ c +bind2 b x f = b x (\a -> f (I a)) + +bind3 :: (d ⊸ I (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c +bind3 b x f = b x (I (\a -> f a)) + +bind4 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind4 b x f = b x (I (\g -> f g)) + +bind5 :: (d ⊸ ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind5 b x f = b x (\g -> f (\a -> g a)) + +bind6 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind6 b x f = b x (I (\g -> f (\a -> g a))) diff --git a/testsuite/tests/linear/should_compile/Linear15.hs b/testsuite/tests/linear/should_compile/Linear15.hs new file mode 100644 index 0000000000..fb244fe8b3 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear15.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear15 where + +correctWhere :: Int ⊸ Int +correctWhere a = g a + where + f :: Int ⊸ Int + f x = x + + g :: Int ⊸ Int + g x = f x diff --git a/testsuite/tests/linear/should_compile/Linear16.hs b/testsuite/tests/linear/should_compile/Linear16.hs new file mode 100644 index 0000000000..8ed8b5b36c --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear16.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE RebindableSyntax #-} +module Linear16 where + +-- Rebindable do notation + +(>>=) :: a ⊸ (a ⊸ b) ⊸ b +(>>=) x f = f x + +-- `fail` is needed due to pattern matching on (); +-- ideally, it shouldn't be there. +fail :: a +fail = fail + +correctDo = do + x <- () + (y,z) <- ((),x) + () <- y + () <- z + () diff --git a/testsuite/tests/linear/should_compile/Linear1Rule.hs b/testsuite/tests/linear/should_compile/Linear1Rule.hs new file mode 100644 index 0000000000..0553c61e84 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear1Rule.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LinearTypes #-} +module Linear1Rule where + +-- Test the 1 <= p rule +f :: a #-> b +f = f + +g :: a # p -> b +g x = f x diff --git a/testsuite/tests/linear/should_compile/Linear3.hs b/testsuite/tests/linear/should_compile/Linear3.hs new file mode 100644 index 0000000000..52b9571085 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear3.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear3 where + +correctApp1 :: (a⊸b) ⊸ a ⊸ b +correctApp1 f a = f a + +correctApp2 :: (a⊸a) -> a ⊸ a +correctApp2 f a = f (f a) + +correctApp3 :: Int ⊸ Int +correctApp3 x = f x + where + f :: Int ⊸ Int + f y = y + +correctApp4 :: Int ⊸ Int +correctApp4 x = f (f x) + where + f :: Int ⊸ Int + f y = y + +correctIf :: Bool ⊸ a ⊸ a +correctIf x n = + if x then n else n diff --git a/testsuite/tests/linear/should_compile/Linear4.hs b/testsuite/tests/linear/should_compile/Linear4.hs new file mode 100644 index 0000000000..7f025e0a0f --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear4.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase, GADTs #-} +module Linear4 where + +correctCase :: Bool ⊸ a ⊸ a +correctCase x n = + case x of + True -> n + False -> n diff --git a/testsuite/tests/linear/should_compile/Linear6.hs b/testsuite/tests/linear/should_compile/Linear6.hs new file mode 100644 index 0000000000..ea095237f5 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear6.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear6 where + +correctEqn :: Bool ⊸ Int ⊸ Int +correctEqn True n = n +correctEqn False n = n diff --git a/testsuite/tests/linear/should_compile/Linear8.hs b/testsuite/tests/linear/should_compile/Linear8.hs new file mode 100644 index 0000000000..a7b6bf95e0 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Linear8.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase #-} +module Linear8 where + +correctLCase :: Int ⊸ Bool -> Int +correctLCase n = \case + True -> n + False -> n diff --git a/testsuite/tests/linear/should_compile/LinearConstructors.hs b/testsuite/tests/linear/should_compile/LinearConstructors.hs new file mode 100644 index 0000000000..0e0f1b547e --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearConstructors.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TupleSections #-} +module LinearConstructors where + +data T a b = MkT a b + +f1 :: a #-> b #-> T a b +f1 = MkT + +f2 :: a #-> b -> T a b +f2 = MkT + +f3 :: a -> b #-> T a b +f3 = MkT + +f4 :: a -> b -> T a b +f4 = MkT + +-- tuple sections +g1 :: a #-> b #-> (a, b, Int) +g1 = (,,0) + +g2 :: a #-> b -> (a, b, Int) +g2 = (,,0) + +g3 :: a -> b #-> (a, b, Int) +g3 = (,,0) + +g4 :: a -> b -> (a, b, Int) +g4 = (,,0) diff --git a/testsuite/tests/linear/should_compile/LinearEmptyCase.hs b/testsuite/tests/linear/should_compile/LinearEmptyCase.hs new file mode 100644 index 0000000000..daa1918b56 --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearEmptyCase.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE EmptyCase, LinearTypes #-} + +module LinearEmptyCase where + +data Void + +f :: a #-> Void -> b +f x y = case y of {} diff --git a/testsuite/tests/linear/should_compile/LinearGuards.hs b/testsuite/tests/linear/should_compile/LinearGuards.hs new file mode 100644 index 0000000000..fae1208176 --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearGuards.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} +module LinearGuards where + +f :: Bool -> a #-> a +f b a | b = a + | True = a diff --git a/testsuite/tests/linear/should_compile/LinearLetRec.hs b/testsuite/tests/linear/should_compile/LinearLetRec.hs new file mode 100644 index 0000000000..e7cf71d324 --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearLetRec.hs @@ -0,0 +1,11 @@ +module NameCache where + +data Name = Name +data NameCache = NameCache !Int !Name + +extendOrigNameCache :: Name -> Name -> Name +extendOrigNameCache _ _ = Name + +initNameCache :: Int -> [Name] -> NameCache +initNameCache us names + = NameCache us (foldl extendOrigNameCache Name names) diff --git a/testsuite/tests/linear/should_compile/LinearPolyDollar.hs b/testsuite/tests/linear/should_compile/LinearPolyDollar.hs new file mode 100644 index 0000000000..7d14351cfc --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearPolyDollar.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} + +module LinearPolyDollar where + +-- The goal of this test is to ensure that the special typing rule of ($) plays +-- well with multiplicity-polymorphic functions + +data F = F Bool + +x = F $ True diff --git a/testsuite/tests/linear/should_compile/LinearTH1.hs b/testsuite/tests/linear/should_compile/LinearTH1.hs new file mode 100644 index 0000000000..4f19b3b449 --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearTH1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes, TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module LinearTH1 where + +x1 = [t|Int -> Int|] diff --git a/testsuite/tests/linear/should_compile/LinearTH2.hs b/testsuite/tests/linear/should_compile/LinearTH2.hs new file mode 100644 index 0000000000..a35f9a1c7e --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearTH2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LinearTypes, TemplateHaskell, RankNTypes #-} +module LinearTH2 where + +x1 = [t|forall p. Int # p -> Int|] diff --git a/testsuite/tests/linear/should_compile/List.hs b/testsuite/tests/linear/should_compile/List.hs new file mode 100644 index 0000000000..4d87dba896 --- /dev/null +++ b/testsuite/tests/linear/should_compile/List.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module List where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint + +See Cabal:Distribution.Types.VersionRange:556 +-} + +import GHC.Base + +data J = J () + +j :: () -> J +j = J + +tup = (j, J) +tup2 = (J, j) + +tup3 = [j, J] +tup4 = [J, j] + +{- + +[1 of 1] Compiling List ( linear-tests/List.hs, linear-tests/List.o ) + +linear-tests/List.hs:17:12: error: + • Couldn't match expected type ‘() -> J’ with actual type ‘() ⊸ J’ + • In the expression: J + In the expression: [j, J] + In an equation for ‘tup3’: tup3 = [j, J] + | +17 | tup3 = [j, J] + | ^ + +linear-tests/List.hs:18:12: error: + • Couldn't match expected type ‘() ⊸ J’ with actual type ‘() -> J’ + • In the expression: j + In the expression: [J, j] + In an equation for ‘tup4’: tup4 = [J, j] + | +18 | tup4 = [J, j] + | ^ + +-} diff --git a/testsuite/tests/linear/should_compile/Makefile b/testsuite/tests/linear/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/linear/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/linear/should_compile/MultConstructor.hs b/testsuite/tests/linear/should_compile/MultConstructor.hs new file mode 100644 index 0000000000..6e631774ba --- /dev/null +++ b/testsuite/tests/linear/should_compile/MultConstructor.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTSyntax, DataKinds, LinearTypes, KindSignatures, ExplicitForAll #-} +module MultConstructor where + +import GHC.Types + +data T p a where + MkT :: a # p -> T p a + +{- +this currently fails +g :: forall (b :: Type). T 'Many b #-> (b,b) +g (MkT x) = (x,x) +-} diff --git a/testsuite/tests/linear/should_compile/OldList.hs b/testsuite/tests/linear/should_compile/OldList.hs new file mode 100644 index 0000000000..2ed7b8aaf2 --- /dev/null +++ b/testsuite/tests/linear/should_compile/OldList.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RankNTypes #-} + +{- +This is a simplified version of Data.OldList module from base. +This caused an assertion failure in earlier version of linear +types implementation. +-} + +module Data.OldList where + +import GHC.Base + +sortBy :: forall a . (a -> a -> Ordering) -> [a] +sortBy cmp = [] + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + +-- descending :: a -> [a] -> [a] -> [[a]] + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending :: a -> (forall i . [a] # i -> [a]) -> [a] -> [[a]] + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b foo bs + where + foo :: [a] # k -> [a] + foo ys = as (a:ys) + ascending a as bs = let !x = as [a] + in x : sequences bs diff --git a/testsuite/tests/linear/should_compile/Op.hs b/testsuite/tests/linear/should_compile/Op.hs new file mode 100644 index 0000000000..725fd222d9 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Op.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Op where +{- +See Control.Arrow and Data.Functor.Contravariant +-} + +import GHC.Base + +class Or p where + or :: p a b -> p a b -> p a b + +instance Or (->) where + or x _ = x + + +foo = or Just (\x -> Just x) + +{- +This caused an error in the earlier version of linear types: + +linear-tests/Op.hs:18:16: error: + • Couldn't match expected type ‘a ⊸ Maybe a’ + with actual type ‘a0 -> Maybe a0’ + • The lambda expression ‘\ x -> Just x’ has one argument, + its type is ‘p0 a b0’, + it is specialized to ‘a ⊸ Maybe a’ + In the second argument of ‘or’, namely ‘(\ x -> Just x)’ + In the expression: or Just (\ x -> Just x) + • Relevant bindings include + foo :: a ⊸ Maybe a (bound at linear-tests/Op.hs:18:1) + | +18 | foo = or Just (\x -> Just x) + | ^^^^^^^^^^^^ +-} diff --git a/testsuite/tests/linear/should_compile/Pr110.hs b/testsuite/tests/linear/should_compile/Pr110.hs new file mode 100644 index 0000000000..a3311cb7b8 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Pr110.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +module Pr110 where + +data Bloop = Bloop Bool + +g :: Bloop #-> Bool +g (Bloop x) = x + +h :: Bool #-> Bloop +h x = Bloop x diff --git a/testsuite/tests/linear/should_compile/RankN.hs b/testsuite/tests/linear/should_compile/RankN.hs new file mode 100644 index 0000000000..cadefa5290 --- /dev/null +++ b/testsuite/tests/linear/should_compile/RankN.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +module RankN where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +import GHC.Base +{- +class Data a where + gunfold :: (forall b r. c (b -> r) -> c r) + -> (forall r. r -> c r) + -> c a + +foo = 1 +{-# NOINLINE foo #-} + +instance Data [a] where + gunfold k z = k (k (z (:))) + + +--qux :: Identity (Int ⊸ Int) +qux = Identity Just + +app :: Identity (a -> b) -> Identity a -> Identity b +app (Identity f) (Identity a) = Identity (f a) + +example = app qux (Identity 5) + +--unqux :: Int ⊸ Int +unqux = Just + +unapp :: (a -> b) -> a -> b +unapp f a = f a + +example1 = unapp unqux 5 + +foo :: Identity (a -> b) -> a -> b +foo = runIdentity + +fooTest = foo (Identity Just) + +foo2 :: (a -> b) -> a -> b +foo2 = ($) + +fooTest2 = let f = Just in foo2 f +-} + +data Identity a = Identity { runIdentity :: a } + +extraTest = (id Identity) :: a -> Identity a diff --git a/testsuite/tests/linear/should_compile/T1735Min.hs b/testsuite/tests/linear/should_compile/T1735Min.hs new file mode 100644 index 0000000000..8800272328 --- /dev/null +++ b/testsuite/tests/linear/should_compile/T1735Min.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UndecidableInstances, Rank2Types, + KindSignatures, EmptyDataDecls, MultiParamTypeClasses, CPP #-} + +module T1735_Help.Basics where + +data Proxy a = Proxy + +class Data ctx a where + gunfold :: Proxy ctx + -> (forall b r. Data ctx b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> Constr + -> c a + + +newtype ID x = ID { unID :: x } + +fromConstrB :: Data ctx a + => Proxy ctx + -> (forall b. Data ctx b => b) + -> Constr + -> a +fromConstrB ctx f = unID . gunfold ctx k z + where + k c = ID (unID c f) + z = ID + +data Constr = Constr diff --git a/testsuite/tests/linear/should_compile/Tunboxer.hs b/testsuite/tests/linear/should_compile/Tunboxer.hs new file mode 100644 index 0000000000..c6bc7f5f38 --- /dev/null +++ b/testsuite/tests/linear/should_compile/Tunboxer.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -O #-} +module TUnboxer where + +-- This checks that the multiplicity of unboxer inside MkId.wrapCo is correct. +-- The test is a minimized version of base/GHC/Event/PSQ.hs and requires -O. +newtype Unique = Unique Int + +data IntPSQ = Bin !Unique + +deleteView :: Unique -> () +deleteView k = Bin k `seq` () diff --git a/testsuite/tests/linear/should_compile/TupSection.hs b/testsuite/tests/linear/should_compile/TupSection.hs new file mode 100644 index 0000000000..ea401e6e97 --- /dev/null +++ b/testsuite/tests/linear/should_compile/TupSection.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TupleSections #-} +module TupSection where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +myAp :: (a -> b) -> a -> b +myAp f x = f x + +foo = myAp (,()) () + +qux = ("go2",) $ () diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T new file mode 100644 index 0000000000..8b11b9ccb9 --- /dev/null +++ b/testsuite/tests/linear/should_compile/all.T @@ -0,0 +1,37 @@ +broken_multiplicity_syntax = 94 # https://github.com/tweag/ghc/issues/94 + +test('anf', normal, compile, ['']) +test('Arity2', normal, compile, ['']) +test('Branches', normal, compile, ['']) +test('CSETest', normal, compile, ['']) +test('Dollar2', normal, compile, ['']) +test('DollarDefault', normal, compile, ['']) +test('DollarTest', normal, compile, ['']) +test('Foldr', normal, compile, ['']) +test('Iden', normal, compile, ['']) +test('List', normal, compile, ['']) +test('OldList', expect_broken(broken_multiplicity_syntax), compile, ['']) +test('Op', normal, compile, ['']) +test('RankN', normal, compile, ['']) +test('T1735Min', normal, compile, ['']) +test('TupSection', normal, compile, ['']) +test('Pr110', normal, compile, ['']) +test('Linear10', normal, compile, ['']) +test('Linear12', normal, compile, ['']) +test('Linear14', expect_broken(298), compile, ['']) +test('Linear15', normal, compile, ['']) +test('Linear16', normal, compile, ['']) +test('Linear3', normal, compile, ['']) +test('Linear4', expect_broken(20), compile, ['']) +test('Linear6', normal, compile, ['']) +test('Linear8', normal, compile, ['']) +test('LinearGuards', normal, compile, ['']) +test('LinearPolyDollar', normal, compile, ['']) +test('LinearConstructors', normal, compile, ['']) +test('Linear1Rule', expect_broken(broken_multiplicity_syntax), compile, ['']) +test('LinearEmptyCase', normal, compile, ['']) +test('Tunboxer', normal, compile, ['']) +test('MultConstructor', expect_broken(broken_multiplicity_syntax), compile, ['']) +test('LinearLetRec', expect_broken(405), compile, ['-O -dlinear-core-lint']) +test('LinearTH1', normal, compile, ['']) +test('LinearTH2', expect_broken(broken_multiplicity_syntax), compile, ['']) diff --git a/testsuite/tests/linear/should_compile/anf.hs b/testsuite/tests/linear/should_compile/anf.hs new file mode 100644 index 0000000000..9f1982e397 --- /dev/null +++ b/testsuite/tests/linear/should_compile/anf.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +-- !! Data constructors with strict fields +-- This test should use -funbox-strict-fields + +module Main ( main ) where + +main = print (g (f t)) + +t = MkT 1 2 (3,4) (MkS 5 6) + +g (MkT x _ _ _) = x + +data T = MkT Int !Int !(Int,Int) !(S Int) + +data S a = MkS a a + + +{-# NOINLINE f #-} +f :: T -> T -- Takes apart the thing and puts it + -- back together differently +f (MkT x y (a,b) (MkS p q)) = MkT a b (p,q) (MkS x y) diff --git a/testsuite/tests/linear/should_fail/Linear1.hs b/testsuite/tests/linear/should_fail/Linear1.hs new file mode 100644 index 0000000000..cdb7eed939 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear1.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase, GADTs #-} +{-# LANGUAGE RebindableSyntax #-} +module Linear1 where + + +-- Must fail: +incorrectDup :: a ⊸ (a,a) +incorrectDup x = (x,x) + +-- Must fail: +incorrectDrop :: a ⊸ () +incorrectDrop x = () diff --git a/testsuite/tests/linear/should_fail/Linear1.stderr b/testsuite/tests/linear/should_fail/Linear1.stderr new file mode 100644 index 0000000000..c549d75be3 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear1.stderr @@ -0,0 +1,10 @@ + +Linear1.hs:10:14: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectDup’: incorrectDup x = (x, x) + +Linear1.hs:14:15: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectDrop’: incorrectDrop x = () diff --git a/testsuite/tests/linear/should_fail/Linear11.hs b/testsuite/tests/linear/should_fail/Linear11.hs new file mode 100644 index 0000000000..67b930ac57 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear11.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear11 where + +data Unrestricted a where Unrestricted :: a -> Unrestricted a + +incorrectUnrestricted :: a ⊸ Unrestricted a +incorrectUnrestricted a = Unrestricted a + +data NotUnrestricted a where NotUnrestricted :: a ⊸ NotUnrestricted a + +incorrectUnrestrictedDup :: NotUnrestricted a ⊸ (a,a) +incorrectUnrestrictedDup (NotUnrestricted a) = (a,a) diff --git a/testsuite/tests/linear/should_fail/Linear11.stderr b/testsuite/tests/linear/should_fail/Linear11.stderr new file mode 100644 index 0000000000..cb52fa16f4 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear11.stderr @@ -0,0 +1,13 @@ + +Linear11.hs:9:23: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘a’ + • In an equation for ‘incorrectUnrestricted’: + incorrectUnrestricted a = Unrestricted a + +Linear11.hs:14:43: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘a’ + • In the pattern: NotUnrestricted a + In an equation for ‘incorrectUnrestrictedDup’: + incorrectUnrestrictedDup (NotUnrestricted a) = (a, a) diff --git a/testsuite/tests/linear/should_fail/Linear13.hs b/testsuite/tests/linear/should_fail/Linear13.hs new file mode 100644 index 0000000000..7b9e09c52b --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear13.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear13 where + +incorrectLet :: a ⊸ () +incorrectLet a = let x = a in () + +incorrectLetWithSignature :: (Bool->Bool) #-> () +incorrectLetWithSignature x = let y :: Bool->Bool; y = x in () + +incorrectLazyMatch :: (a,b) ⊸ b +incorrectLazyMatch x = let (a,b) = x in b + +incorrectCasePromotion :: (a,b) ⊸ b +incorrectCasePromotion x = case x of (a,b) -> b diff --git a/testsuite/tests/linear/should_fail/Linear13.stderr b/testsuite/tests/linear/should_fail/Linear13.stderr new file mode 100644 index 0000000000..a781c20da6 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear13.stderr @@ -0,0 +1,28 @@ + +Linear13.hs:6:14: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘a’ + • In an equation for ‘incorrectLet’: + incorrectLet a = let x = a in () + +Linear13.hs:9:27: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectLetWithSignature’: + incorrectLetWithSignature x + = let + y :: Bool -> Bool + y = x + in () + +Linear13.hs:12:20: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectLazyMatch’: + incorrectLazyMatch x = let (a, b) = x in b + +Linear13.hs:15:24: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectCasePromotion’: + incorrectCasePromotion x = case x of { (a, b) -> b } diff --git a/testsuite/tests/linear/should_fail/Linear17.hs b/testsuite/tests/linear/should_fail/Linear17.hs new file mode 100644 index 0000000000..1d8abfdb09 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear17.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE RebindableSyntax #-} +module Linear17 where + +-- Rebindable do notation + +(>>=) :: a ⊸ (a ⊸ b) ⊸ b +(>>=) x f = f x + +-- `fail` is needed due to pattern matching on (); +-- ideally, it shouldn't be there. +fail :: a +fail = fail + +incorrectDo1 = do + x <- () + (y,z) <- ((),()) + () <- y + () <- z + () + +incorrectDo2 = do + x <- () + (y,z) <- ((),x) + () <- y + () + +incorrectDo3 = do + x <- () + (y,z) <- (x,x) + () <- y + () <- z + () diff --git a/testsuite/tests/linear/should_fail/Linear17.stderr b/testsuite/tests/linear/should_fail/Linear17.stderr new file mode 100644 index 0000000000..12193e115b --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear17.stderr @@ -0,0 +1,45 @@ + +Linear17.hs:17:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In a stmt of a 'do' block: x <- () + In the expression: + do x <- () + (y, z) <- ((), ()) + () <- y + () <- z + .... + In an equation for ‘incorrectDo1’: + incorrectDo1 + = do x <- () + (y, z) <- ((), ()) + () <- y + .... + +Linear17.hs:25:6: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘z’ + • In the pattern: (y, z) + In a stmt of a 'do' block: (y, z) <- ((), x) + In the expression: + do x <- () + (y, z) <- ((), x) + () <- y + () + +Linear17.hs:30:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In a stmt of a 'do' block: x <- () + In the expression: + do x <- () + (y, z) <- (x, x) + () <- y + () <- z + .... + In an equation for ‘incorrectDo3’: + incorrectDo3 + = do x <- () + (y, z) <- (x, x) + () <- y + .... diff --git a/testsuite/tests/linear/should_fail/Linear2.hs b/testsuite/tests/linear/should_fail/Linear2.hs new file mode 100644 index 0000000000..bb6f525f01 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear2.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear2 where + +dup :: a -> (a,a) +dup x = (x,x) + +incorrectApp1 :: a ⊸ ((a,Int),(a,Int)) +incorrectApp1 x = dup (x,0) + +incorrectApp2 :: (a->b) -> a ⊸ b +incorrectApp2 f x = f x + +incorrectIf :: Bool -> Int ⊸ Int +incorrectIf x n = + if x then n else 0 diff --git a/testsuite/tests/linear/should_fail/Linear2.stderr b/testsuite/tests/linear/should_fail/Linear2.stderr new file mode 100644 index 0000000000..eec52922a0 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear2.stderr @@ -0,0 +1,16 @@ + +Linear2.hs:9:15: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectApp1’: incorrectApp1 x = dup (x, 0) + +Linear2.hs:12:17: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘incorrectApp2’: incorrectApp2 f x = f x + +Linear2.hs:15:15: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘n’ + • In an equation for ‘incorrectIf’: + incorrectIf x n = if x then n else 0 diff --git a/testsuite/tests/linear/should_fail/Linear5.hs b/testsuite/tests/linear/should_fail/Linear5.hs new file mode 100644 index 0000000000..ad0c80356c --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear5.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear5 where + +incorrectEqn :: Bool -> Int ⊸ Int +incorrectEqn True n = n +incorrectEqn False n = 0 diff --git a/testsuite/tests/linear/should_fail/Linear5.stderr b/testsuite/tests/linear/should_fail/Linear5.stderr new file mode 100644 index 0000000000..4de49fb9d9 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear5.stderr @@ -0,0 +1,5 @@ + +Linear5.hs:7:20: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘n’ + • In an equation for ‘incorrectEqn’: incorrectEqn False n = 0 diff --git a/testsuite/tests/linear/should_fail/Linear7.hs b/testsuite/tests/linear/should_fail/Linear7.hs new file mode 100644 index 0000000000..9ee6438b11 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear7.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase #-} +module Linear7 where + +incorrectLCase :: Int ⊸ Bool -> Int +incorrectLCase n = \case + True -> n + False -> 0 diff --git a/testsuite/tests/linear/should_fail/Linear7.stderr b/testsuite/tests/linear/should_fail/Linear7.stderr new file mode 100644 index 0000000000..9dc596477d --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear7.stderr @@ -0,0 +1,9 @@ + +Linear7.hs:7:16: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘n’ + • In an equation for ‘incorrectLCase’: + incorrectLCase n + = \case + True -> n + False -> 0 diff --git a/testsuite/tests/linear/should_fail/Linear9.hs b/testsuite/tests/linear/should_fail/Linear9.hs new file mode 100644 index 0000000000..011c58e837 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear9.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear9 where + +fst :: (a,b) -> a +fst (a,_) = a + +incorrectFst :: (a,b) ⊸ a +incorrectFst (a,_) = a + +incorrectFstVar :: (a,b) ⊸ a +incorrectFstVar (a,b) = a + +incorrectFirstDup :: (a,b) ⊸ ((a,a),b) +incorrectFirstDup (a,b) = ((a,a),b) + +incorrectFstFst :: ((a,b),c) ⊸ a +incorrectFstFst ((a,_),_) = a + +data Test a + = Foo a a + | Bar a + +incorrectTestFst :: Test a ⊸ a +incorrectTestFst (Foo a _) = a +incorrectTestFst (Bar a) = a diff --git a/testsuite/tests/linear/should_fail/Linear9.stderr b/testsuite/tests/linear/should_fail/Linear9.stderr new file mode 100644 index 0000000000..ab13270ee3 --- /dev/null +++ b/testsuite/tests/linear/should_fail/Linear9.stderr @@ -0,0 +1,43 @@ + +Linear9.hs:9:17: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: _ + In the pattern: (a, _) + In an equation for ‘incorrectFst’: incorrectFst (a, _) = a + +Linear9.hs:12:20: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘b’ + • In the pattern: (a, b) + In an equation for ‘incorrectFstVar’: incorrectFstVar (a, b) = a + +Linear9.hs:15:20: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘a’ + • In the pattern: (a, b) + In an equation for ‘incorrectFirstDup’: + incorrectFirstDup (a, b) = ((a, a), b) + +Linear9.hs:18:21: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: _ + In the pattern: (a, _) + In the pattern: ((a, _), _) + +Linear9.hs:18:24: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: _ + In the pattern: ((a, _), _) + In an equation for ‘incorrectFstFst’: + incorrectFstFst ((a, _), _) = a + +Linear9.hs:25:25: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: _ + In the pattern: Foo a _ + In an equation for ‘incorrectTestFst’: + incorrectTestFst (Foo a _) = a diff --git a/testsuite/tests/linear/should_fail/LinearAsPat.hs b/testsuite/tests/linear/should_fail/LinearAsPat.hs new file mode 100644 index 0000000000..e756f4369f --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearAsPat.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} + +module LinearAsPat where + +shouldFail :: Bool #-> Bool +shouldFail x@True = x diff --git a/testsuite/tests/linear/should_fail/LinearAsPat.stderr b/testsuite/tests/linear/should_fail/LinearAsPat.stderr new file mode 100644 index 0000000000..7d6cc245cf --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearAsPat.stderr @@ -0,0 +1,5 @@ + +LinearAsPat.hs:6:12: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In an equation for ‘shouldFail’: shouldFail x@True = x diff --git a/testsuite/tests/linear/should_fail/LinearBottomMult.hs b/testsuite/tests/linear/should_fail/LinearBottomMult.hs new file mode 100644 index 0000000000..03bf8731a7 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearBottomMult.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs, LinearTypes, ScopedTypeVariables, EmptyCase #-} +module LinearBottomMult where + +-- Check that _|_ * Many is not a subusage of One +-- +data Void +data U a where U :: a -> U a + +elim :: U a #-> () +elim (U _) = () + +f :: a #-> () +f x = elim (U (\(a :: Void) -> case a of {})) diff --git a/testsuite/tests/linear/should_fail/LinearBottomMult.stderr b/testsuite/tests/linear/should_fail/LinearBottomMult.stderr new file mode 100644 index 0000000000..fd846070d8 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearBottomMult.stderr @@ -0,0 +1,6 @@ + +LinearBottomMult.hs:13:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘f’: + f x = elim (U (\ (a :: Void) -> case a of)) diff --git a/testsuite/tests/linear/should_fail/LinearConfusedDollar.hs b/testsuite/tests/linear/should_fail/LinearConfusedDollar.hs new file mode 100644 index 0000000000..2cd1628eeb --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearConfusedDollar.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE LinearTypes #-} +module LinearConfusedDollar where + +-- When ($) becomes polymorphic in the multiplicity, then, this test case won't +-- hold anymore. But, as it stands, it produces untyped desugared code, hence +-- must be rejected. + +f :: a #-> a +f x = x + +g :: a #-> a +g x = f $ x diff --git a/testsuite/tests/linear/should_fail/LinearConfusedDollar.stderr b/testsuite/tests/linear/should_fail/LinearConfusedDollar.stderr new file mode 100644 index 0000000000..4abdd1c18c --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearConfusedDollar.stderr @@ -0,0 +1,6 @@ + +LinearConfusedDollar.hs:12:7: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from an application + • In the expression: f $ x + In an equation for ‘g’: g x = f $ x diff --git a/testsuite/tests/linear/should_fail/LinearErrOrigin.hs b/testsuite/tests/linear/should_fail/LinearErrOrigin.hs new file mode 100644 index 0000000000..1eeb149959 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearErrOrigin.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LinearTypes #-} +module LinearErrOrigin where + +-- The error message should mention "arising from multiplicity of x". + +foo :: (a # p -> b) -> a # q -> b +foo f x = f x diff --git a/testsuite/tests/linear/should_fail/LinearErrOrigin.stderr b/testsuite/tests/linear/should_fail/LinearErrOrigin.stderr new file mode 100644 index 0000000000..10b889a9a8 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearErrOrigin.stderr @@ -0,0 +1,16 @@ + +LinearErrOrigin.hs:7:7: error: + • Couldn't match type ‘p’ with ‘q’ arising from multiplicity of ‘x’ + ‘p’ is a rigid type variable bound by + the type signature for: + foo :: forall a b. (a -> b) -> a -> b + at LinearErrOrigin.hs:6:1-35 + ‘q’ is a rigid type variable bound by + the type signature for: + foo :: forall a b. (a -> b) -> a -> b + at LinearErrOrigin.hs:6:1-35 + • In an equation for ‘foo’: foo f x = f x + • Relevant bindings include + f :: a # p -> b (bound at LinearErrOrigin.hs:7:5) + foo :: (a # p -> b) -> a # q -> b + (bound at LinearErrOrigin.hs:7:1) diff --git a/testsuite/tests/linear/should_fail/LinearGADTNewtype.hs b/testsuite/tests/linear/should_fail/LinearGADTNewtype.hs new file mode 100644 index 0000000000..789b8cc3b6 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearGADTNewtype.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE LinearTypes, GADTs #-} +newtype A where + A :: Int -> A diff --git a/testsuite/tests/linear/should_fail/LinearGADTNewtype.stderr b/testsuite/tests/linear/should_fail/LinearGADTNewtype.stderr new file mode 100644 index 0000000000..42207d4f72 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearGADTNewtype.stderr @@ -0,0 +1,5 @@ + +LinearGADTNewtype.hs:3:4: error: + • A newtype constructor must be linear + • In the definition of data constructor ‘A’ + In the newtype declaration for ‘A’ diff --git a/testsuite/tests/linear/should_fail/LinearIf.hs b/testsuite/tests/linear/should_fail/LinearIf.hs new file mode 100644 index 0000000000..b19873120c --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearIf.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE RebindableSyntax #-} + +module LinearIf where + +import Prelude (Bool(..), Char) + +ifThenElse :: Bool -> a -> a -> a +ifThenElse True x _ = x +ifThenElse False _ y = y + +f :: Bool #-> Char #-> Char #-> Char +f b x y = if b then x else y + -- 'f' ought to be unrestricted in all three arguments because it desugars to + -- > ifThenElse b x y diff --git a/testsuite/tests/linear/should_fail/LinearIf.stderr b/testsuite/tests/linear/should_fail/LinearIf.stderr new file mode 100644 index 0000000000..c34bec5f4d --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearIf.stderr @@ -0,0 +1,15 @@ + +LinearIf.hs:13:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘b’ + • In an equation for ‘f’: f b x y = if b then x else y + +LinearIf.hs:13:5: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘f’: f b x y = if b then x else y + +LinearIf.hs:13:7: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘y’ + • In an equation for ‘f’: f b x y = if b then x else y diff --git a/testsuite/tests/linear/should_fail/LinearKind.hs b/testsuite/tests/linear/should_fail/LinearKind.hs new file mode 100644 index 0000000000..a60554a7a7 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearKind.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LinearTypes, KindSignatures #-} +module LinearKind where + +data A :: * #-> * diff --git a/testsuite/tests/linear/should_fail/LinearKind.stderr b/testsuite/tests/linear/should_fail/LinearKind.stderr new file mode 100644 index 0000000000..5ac2825b21 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearKind.stderr @@ -0,0 +1,5 @@ + +LinearKind.hs:4:11: error: + • Linear arrows disallowed in kinds: * #-> * + • In the kind ‘* #-> *’ + In the data type declaration for ‘A’ diff --git a/testsuite/tests/linear/should_fail/LinearLazyPat.hs b/testsuite/tests/linear/should_fail/LinearLazyPat.hs new file mode 100644 index 0000000000..8ed4024c40 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearLazyPat.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LinearTypes #-} +module LinearLazyPat where + +f :: (a,b) #-> (b,a) +f ~(x,y) = (y,x) diff --git a/testsuite/tests/linear/should_fail/LinearLazyPat.stderr b/testsuite/tests/linear/should_fail/LinearLazyPat.stderr new file mode 100644 index 0000000000..1893d10417 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearLazyPat.stderr @@ -0,0 +1,6 @@ + +LinearLazyPat.hs:5:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: ~(x, y) + In an equation for ‘f’: f ~(x, y) = (y, x) diff --git a/testsuite/tests/linear/should_fail/LinearLet.hs b/testsuite/tests/linear/should_fail/LinearLet.hs new file mode 100644 index 0000000000..bf822a8a6e --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearLet.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LinearTypes #-} +module LinearLet where + +f :: a #-> (a,a) +f x = let y = x in (y,y) diff --git a/testsuite/tests/linear/should_fail/LinearLet.stderr b/testsuite/tests/linear/should_fail/LinearLet.stderr new file mode 100644 index 0000000000..3b94833d7e --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearLet.stderr @@ -0,0 +1,5 @@ + +LinearLet.hs:5:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘f’: f x = let y = x in (y, y) diff --git a/testsuite/tests/linear/should_fail/LinearNoExt.hs b/testsuite/tests/linear/should_fail/LinearNoExt.hs new file mode 100644 index 0000000000..2671246f21 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearNoExt.hs @@ -0,0 +1,3 @@ +module LinearNoExt where + +type T = a #-> a diff --git a/testsuite/tests/linear/should_fail/LinearNoExt.stderr b/testsuite/tests/linear/should_fail/LinearNoExt.stderr new file mode 100644 index 0000000000..452409586d --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearNoExt.stderr @@ -0,0 +1,3 @@ + +LinearNoExt.hs:3:12: error: + Enable LinearTypes to allow linear functions diff --git a/testsuite/tests/linear/should_fail/LinearPartialSig.hs b/testsuite/tests/linear/should_fail/LinearPartialSig.hs new file mode 100644 index 0000000000..01dbeddfba --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearPartialSig.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} +module LinearPartialSig where + +-- We should suggest that _ :: Multiplicity +f :: a # _ -> a +f x = x diff --git a/testsuite/tests/linear/should_fail/LinearPartialSig.stderr b/testsuite/tests/linear/should_fail/LinearPartialSig.stderr new file mode 100644 index 0000000000..4d25260bf2 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearPartialSig.stderr @@ -0,0 +1,7 @@ + +LinearPartialSig.hs:5:13: error: + • Found type wildcard ‘_’ + standing for ‘'Many :: GHC.Types.Multiplicity’ + To use the inferred type, enable PartialTypeSignatures + • In the type ‘a # _ -> a’ + In the type signature: f :: a # _ -> a diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn.hs b/testsuite/tests/linear/should_fail/LinearPatSyn.hs new file mode 100644 index 0000000000..3e947dba2e --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearPatSyn.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE PatternSynonyms #-} + +module LinearPatSyn where + +-- Linearity and pattern synonyms should eventually play well together, but it +-- seems to require changes to the desugarer. So currently pattern synonyms are +-- disallowed in linear patterns. + +pattern P :: b #-> a #-> (a, b) +pattern P y x = (x, y) + +s :: (a, b) #-> (b, a) +s (P y x) = (y, x) diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn.stderr b/testsuite/tests/linear/should_fail/LinearPatSyn.stderr new file mode 100644 index 0000000000..f7c3aab406 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearPatSyn.stderr @@ -0,0 +1,6 @@ + +LinearPatSyn.hs:14:4: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: P y x + In an equation for ‘s’: s (P y x) = (y, x) diff --git a/testsuite/tests/linear/should_fail/LinearPolyType.hs b/testsuite/tests/linear/should_fail/LinearPolyType.hs new file mode 100644 index 0000000000..bcf46eed9f --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearPolyType.hs @@ -0,0 +1,16 @@ +-- Source: https://github.com/ghc-proposals/ghc-proposals/pull/111#issuecomment-438125526 +{-# LANGUAGE LinearTypes, GADTs, KindSignatures, DataKinds, TypeFamilies, PolyKinds #-} +module LinearPolyType where + +import GHC.Types +data SBool :: Bool -> Type where + STrue :: SBool True + SFalse :: SBool False + +type family If b t f where + If True t _ = t + If False _ f = f + +dep :: SBool b -> Int # If b One Many -> Int +dep STrue x = x +dep SFalse _ = 0 diff --git a/testsuite/tests/linear/should_fail/LinearPolyType.stderr b/testsuite/tests/linear/should_fail/LinearPolyType.stderr new file mode 100644 index 0000000000..fab6dfcc9b --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearPolyType.stderr @@ -0,0 +1,3 @@ + +LinearPolyType.hs:15:1: error: + Multiplicity coercions are currently not supported diff --git a/testsuite/tests/linear/should_fail/LinearRecordUpdate.hs b/testsuite/tests/linear/should_fail/LinearRecordUpdate.hs new file mode 100644 index 0000000000..e143dbd604 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearRecordUpdate.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LinearTypes #-} + +module LinearRecordUpdate where + +data R = R { x :: Int, y :: Bool } + +shouldFail :: R #-> R +shouldFail r = r { y = False } diff --git a/testsuite/tests/linear/should_fail/LinearRecordUpdate.stderr b/testsuite/tests/linear/should_fail/LinearRecordUpdate.stderr new file mode 100644 index 0000000000..aa32a9db68 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearRecordUpdate.stderr @@ -0,0 +1,5 @@ + +LinearRecordUpdate.hs:8:12: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘r’ + • In an equation for ‘shouldFail’: shouldFail r = r {y = False} diff --git a/testsuite/tests/linear/should_fail/LinearSeq.hs b/testsuite/tests/linear/should_fail/LinearSeq.hs new file mode 100644 index 0000000000..0f2ed39c93 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearSeq.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} + +module LinearSeq where + +bad :: a #-> () +bad x = seq x () diff --git a/testsuite/tests/linear/should_fail/LinearSeq.stderr b/testsuite/tests/linear/should_fail/LinearSeq.stderr new file mode 100644 index 0000000000..f6b22b5999 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearSeq.stderr @@ -0,0 +1,5 @@ + +LinearSeq.hs:6:5: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘bad’: bad x = seq x () diff --git a/testsuite/tests/linear/should_fail/LinearSequenceExpr.hs b/testsuite/tests/linear/should_fail/LinearSequenceExpr.hs new file mode 100644 index 0000000000..ff3ac9cedb --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearSequenceExpr.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedLists #-} + +module LinearSequenceExpr where + +f :: Char #-> Char #-> [Char] +f x y = [x .. y] +-- This ought to fail, because `fromList` in base, is unrestricted diff --git a/testsuite/tests/linear/should_fail/LinearSequenceExpr.stderr b/testsuite/tests/linear/should_fail/LinearSequenceExpr.stderr new file mode 100644 index 0000000000..a3fdb4d7df --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearSequenceExpr.stderr @@ -0,0 +1,10 @@ + +LinearSequenceExpr.hs:7:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘f’: f x y = [x .. y] + +LinearSequenceExpr.hs:7:5: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘y’ + • In an equation for ‘f’: f x y = [x .. y] diff --git a/testsuite/tests/linear/should_fail/LinearVar.hs b/testsuite/tests/linear/should_fail/LinearVar.hs new file mode 100644 index 0000000000..7b4cde3647 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearVar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LinearTypes #-} +module LinearVar where + +f :: a # m -> b +f = undefined :: a -> b diff --git a/testsuite/tests/linear/should_fail/LinearVar.stderr b/testsuite/tests/linear/should_fail/LinearVar.stderr new file mode 100644 index 0000000000..04014ce79b --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearVar.stderr @@ -0,0 +1,13 @@ + +LinearVar.hs:5:5: error: + • Couldn't match type ‘m’ with ‘'Many’ + ‘m’ is a rigid type variable bound by + the type signature for: + f :: forall a b. a -> b + at LinearVar.hs:4:1-16 + Expected type: a # m -> b + Actual type: a -> b + • In the expression: undefined :: a -> b + In an equation for ‘f’: f = undefined :: a -> b + • Relevant bindings include + f :: a # m -> b (bound at LinearVar.hs:5:1) diff --git a/testsuite/tests/linear/should_fail/LinearViewPattern.hs b/testsuite/tests/linear/should_fail/LinearViewPattern.hs new file mode 100644 index 0000000000..737393911b --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearViewPattern.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE ViewPatterns #-} + +module LinearViewPattern where + +-- This is probably inessential. We are just protecting against potential +-- incorrect Core being emitted by the desugarer. When we understand linear view +-- pattern better, we will probably want to remove this test. + +f :: Bool #-> Bool +f (not -> True) = True diff --git a/testsuite/tests/linear/should_fail/LinearViewPattern.stderr b/testsuite/tests/linear/should_fail/LinearViewPattern.stderr new file mode 100644 index 0000000000..c0aa969741 --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearViewPattern.stderr @@ -0,0 +1,6 @@ + +LinearViewPattern.hs:11:4: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from a non-linear pattern + • In the pattern: not -> True + In an equation for ‘f’: f (not -> True) = True diff --git a/testsuite/tests/linear/should_fail/Makefile b/testsuite/tests/linear/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/linear/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/linear/should_fail/TypeClass.hs b/testsuite/tests/linear/should_fail/TypeClass.hs new file mode 100644 index 0000000000..9752810dc4 --- /dev/null +++ b/testsuite/tests/linear/should_fail/TypeClass.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LinearTypes #-} +module Foo where + +data Either a b = Left a | Right b + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either f g (Left a) = f a +either f g (Right b) = g b + +class Iden p where + iden :: p a a + +instance Iden (->) where + iden x = x + +class Cat p where + comp :: p b c -> p a b -> p a c + +instance Cat (->) where + comp f g = \x -> f (g x) + +class ArrowChoice a where + (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c') + (|||) :: a b d -> a c d -> a (Either b c) d + +instance ArrowChoice (->) where +-- This doesn't work as |p| is inferred to be |-o| because of |Left|. +-- Then GHC complains that |f| is not the same type before it realises +-- that the overall type must be (->) +-- f +++ g = (Left `comp` f) ||| (Right `comp` g) + f +++ g = (comp @(->) Left f) ||| (comp @(->) Right g) + (|||) = either + + +-- This shouldn't work +foo :: a ⊸ a +foo = iden diff --git a/testsuite/tests/linear/should_fail/TypeClass.stderr b/testsuite/tests/linear/should_fail/TypeClass.stderr new file mode 100644 index 0000000000..97ff625686 --- /dev/null +++ b/testsuite/tests/linear/should_fail/TypeClass.stderr @@ -0,0 +1,5 @@ + +TypeClass.hs:45:7: error: + • No instance for (Iden (FUN 'One)) arising from a use of ‘iden’ + • In the expression: iden + In an equation for ‘foo’: foo = iden diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T new file mode 100644 index 0000000000..67906053dc --- /dev/null +++ b/testsuite/tests/linear/should_fail/all.T @@ -0,0 +1,29 @@ +broken_multiplicity_syntax = 94 # https://github.com/tweag/ghc/issues/94 + +test('TypeClass', normal, compile_fail, ['']) +test('Linear11', normal, compile_fail, ['']) +test('Linear13', normal, compile_fail, ['']) +test('Linear17', normal, compile_fail, ['']) +test('Linear1', normal, compile_fail, ['']) +test('Linear2', normal, compile_fail, ['']) +test('Linear5', normal, compile_fail, ['']) +test('Linear7', normal, compile_fail, ['']) +test('Linear9', normal, compile_fail, ['']) +test('LinearNoExt', normal, compile_fail, ['']) +test('LinearAsPat', normal, compile_fail, ['']) +test('LinearLet', normal, compile_fail, ['']) +test('LinearLazyPat', normal, compile_fail, ['']) +test('LinearRecordUpdate', normal, compile_fail, ['']) +test('LinearSeq', normal, compile_fail, ['']) +test('LinearViewPattern', normal, compile_fail, ['']) +test('LinearConfusedDollar', normal, compile_fail, ['']) +test('LinearPatSyn', normal, compile_fail, ['']) +test('LinearGADTNewtype', normal, compile_fail, ['']) +test('LinearPartialSig', expect_broken(broken_multiplicity_syntax), compile_fail, ['']) +test('LinearKind', normal, compile_fail, ['']) +test('LinearVar', expect_broken(broken_multiplicity_syntax), compile_fail, ['']) +test('LinearErrOrigin', expect_broken(broken_multiplicity_syntax), compile_fail, ['']) +test('LinearPolyType', expect_broken([436, broken_multiplicity_syntax]), compile_fail, ['']) # not supported yet (#354) +test('LinearBottomMult', normal, compile_fail, ['']) +test('LinearSequenceExpr', normal, compile_fail, ['']) +test('LinearIf', normal, compile_fail, ['']) diff --git a/testsuite/tests/linear/should_run/LinearGhci.script b/testsuite/tests/linear/should_run/LinearGhci.script new file mode 100644 index 0000000000..78f81ef8d2 --- /dev/null +++ b/testsuite/tests/linear/should_run/LinearGhci.script @@ -0,0 +1,11 @@ +data T a = MkT a +:type +v MkT +:set -XLinearTypes +:type +v MkT +:set -XGADTs +data T a where MkT :: a #-> a -> T a +:info T +data T a b m n r = MkT a b m n r +:set -fprint-explicit-foralls +-- check that user variables are not renamed (see dataConMulVars) +:type +v MkT diff --git a/testsuite/tests/linear/should_run/LinearGhci.stdout b/testsuite/tests/linear/should_run/LinearGhci.stdout new file mode 100644 index 0000000000..ed5c9cfe64 --- /dev/null +++ b/testsuite/tests/linear/should_run/LinearGhci.stdout @@ -0,0 +1,7 @@ +MkT :: a -> T a +MkT :: a -> T a +type T :: * -> * +data T a where + MkT :: a #-> a -> T a + -- Defined at <interactive>:6:1 +MkT :: forall a b m n r. a -> b -> m -> n -> r -> T a b m n r diff --git a/testsuite/tests/linear/should_run/LinearTypeable.hs b/testsuite/tests/linear/should_run/LinearTypeable.hs new file mode 100644 index 0000000000..69772f7b33 --- /dev/null +++ b/testsuite/tests/linear/should_run/LinearTypeable.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes, TypeOperators #-} +module Main (main) where + +import Data.Typeable +import Data.Maybe + +x :: Maybe ((Int -> Int) :~: (Int #-> Int)) +x = eqT + +main = print (isJust x) diff --git a/testsuite/tests/linear/should_run/LinearTypeable.stdout b/testsuite/tests/linear/should_run/LinearTypeable.stdout new file mode 100644 index 0000000000..bc59c12aa1 --- /dev/null +++ b/testsuite/tests/linear/should_run/LinearTypeable.stdout @@ -0,0 +1 @@ +False diff --git a/testsuite/tests/linear/should_run/Makefile b/testsuite/tests/linear/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/linear/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/linear/should_run/all.T b/testsuite/tests/linear/should_run/all.T new file mode 100644 index 0000000000..1fbe20581c --- /dev/null +++ b/testsuite/tests/linear/should_run/all.T @@ -0,0 +1,2 @@ +test('LinearTypeable', normal, compile_and_run, ['']) +test('LinearGhci', normal, ghci_script, ['LinearGhci.script']) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 8d597ad371..b14b69dc04 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -63,13 +63,15 @@ [] (Nothing) (PrefixCon - [({ DumpParsedAst.hs:7:26-30 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpParsedAst.hs:7:26-30 } - (Unqual - {OccName: Peano}))))]) + [(HsScaled + (HsLinearArrow) + ({ DumpParsedAst.hs:7:26-30 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpParsedAst.hs:7:26-30 } + (Unqual + {OccName: Peano})))))]) (Nothing)))] ({ <no location info> } []))))) @@ -253,26 +255,28 @@ [] (Nothing) (PrefixCon - [({ DumpParsedAst.hs:14:25-29 } - (HsParTy - (NoExtField) - ({ DumpParsedAst.hs:14:26-28 } - (HsAppTy - (NoExtField) - ({ DumpParsedAst.hs:14:26 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpParsedAst.hs:14:26 } - (Unqual - {OccName: f})))) - ({ DumpParsedAst.hs:14:28 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpParsedAst.hs:14:28 } - (Unqual - {OccName: a}))))))))]) + [(HsScaled + (HsLinearArrow) + ({ DumpParsedAst.hs:14:25-29 } + (HsParTy + (NoExtField) + ({ DumpParsedAst.hs:14:26-28 } + (HsAppTy + (NoExtField) + ({ DumpParsedAst.hs:14:26 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpParsedAst.hs:14:26 } + (Unqual + {OccName: f})))) + ({ DumpParsedAst.hs:14:28 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpParsedAst.hs:14:28 } + (Unqual + {OccName: a})))))))))]) (Nothing)))] ({ <no location info> } []))))) @@ -386,6 +390,7 @@ ({ DumpParsedAst.hs:16:31-39 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpParsedAst.hs:16:31 } (HsTyVar (NoExtField) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index a2e4cd1e9e..220a2ecd0b 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -99,12 +99,14 @@ [] (Nothing) (PrefixCon - [({ DumpRenamedAst.hs:9:26-30 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:9:26-30 } - {Name: DumpRenamedAst.Peano})))]) + [(HsScaled + (HsLinearArrow) + ({ DumpRenamedAst.hs:9:26-30 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:9:26-30 } + {Name: DumpRenamedAst.Peano}))))]) (Nothing)))] ({ <no location info> } []))))] @@ -252,6 +254,7 @@ ({ DumpRenamedAst.hs:15:20-33 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:15:20 } (HsTyVar (NoExtField) @@ -261,6 +264,7 @@ ({ DumpRenamedAst.hs:15:25-33 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:15:25 } (HsTyVar (NoExtField) @@ -304,6 +308,7 @@ ({ DumpRenamedAst.hs:18:28-36 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:18:28 } (HsTyVar (NoExtField) @@ -327,12 +332,14 @@ ({ DumpRenamedAst.hs:18:42-60 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:18:42-52 } (HsParTy (NoExtField) ({ DumpRenamedAst.hs:18:43-51 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:18:43 } (HsTyVar (NoExtField) @@ -362,53 +369,56 @@ [] (Nothing) (PrefixCon - [({ DumpRenamedAst.hs:19:10-34 } - (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:19:11-33 } - (HsForAllTy - (NoExtField) - (HsForAllInvis + [(HsScaled + (HsLinearArrow) + ({ DumpRenamedAst.hs:19:10-34 } + (HsParTy + (NoExtField) + ({ DumpRenamedAst.hs:19:11-33 } + (HsForAllTy (NoExtField) - [({ DumpRenamedAst.hs:19:18-19 } - (UserTyVar - (NoExtField) - (SpecifiedSpec) - ({ DumpRenamedAst.hs:19:18-19 } - {Name: xx})))]) - ({ DumpRenamedAst.hs:19:22-33 } - (HsFunTy + (HsForAllInvis (NoExtField) - ({ DumpRenamedAst.hs:19:22-25 } - (HsAppTy - (NoExtField) - ({ DumpRenamedAst.hs:19:22 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:19:22 } - {Name: f}))) - ({ DumpRenamedAst.hs:19:24-25 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:19:24-25 } - {Name: xx}))))) - ({ DumpRenamedAst.hs:19:30-33 } - (HsAppTy - (NoExtField) - ({ DumpRenamedAst.hs:19:30 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:19:30 } - {Name: g}))) - ({ DumpRenamedAst.hs:19:32-33 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:19:32-33 } - {Name: xx})))))))))))]) + [({ DumpRenamedAst.hs:19:18-19 } + (UserTyVar + (NoExtField) + (SpecifiedSpec) + ({ DumpRenamedAst.hs:19:18-19 } + {Name: xx})))]) + ({ DumpRenamedAst.hs:19:22-33 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ DumpRenamedAst.hs:19:22-25 } + (HsAppTy + (NoExtField) + ({ DumpRenamedAst.hs:19:22 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:19:22 } + {Name: f}))) + ({ DumpRenamedAst.hs:19:24-25 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:19:24-25 } + {Name: xx}))))) + ({ DumpRenamedAst.hs:19:30-33 } + (HsAppTy + (NoExtField) + ({ DumpRenamedAst.hs:19:30 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:19:30 } + {Name: g}))) + ({ DumpRenamedAst.hs:19:32-33 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:19:32-33 } + {Name: xx}))))))))))))]) ({ DumpRenamedAst.hs:19:39-45 } (HsAppTy (NoExtField) @@ -485,24 +495,26 @@ [] (Nothing) (PrefixCon - [({ DumpRenamedAst.hs:21:25-29 } - (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:21:26-28 } - (HsAppTy - (NoExtField) - ({ DumpRenamedAst.hs:21:26 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:21:26 } - {Name: f}))) - ({ DumpRenamedAst.hs:21:28 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ DumpRenamedAst.hs:21:28 } - {Name: a})))))))]) + [(HsScaled + (HsLinearArrow) + ({ DumpRenamedAst.hs:21:25-29 } + (HsParTy + (NoExtField) + ({ DumpRenamedAst.hs:21:26-28 } + (HsAppTy + (NoExtField) + ({ DumpRenamedAst.hs:21:26 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:21:26 } + {Name: f}))) + ({ DumpRenamedAst.hs:21:28 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ DumpRenamedAst.hs:21:28 } + {Name: a}))))))))]) (Nothing)))] ({ <no location info> } []))))] @@ -608,6 +620,7 @@ ({ DumpRenamedAst.hs:23:31-39 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:23:31 } (HsTyVar (NoExtField) diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index a23369a65e..689cc4187f 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -274,6 +274,7 @@ ({ KindSigs.hs:22:8-44 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ KindSigs.hs:22:8-20 } (HsParTy (NoExtField) @@ -297,6 +298,7 @@ ({ KindSigs.hs:22:25-44 } (HsFunTy (NoExtField) + (HsUnrestrictedArrow) ({ KindSigs.hs:22:25-28 } (HsTyVar (NoExtField) diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index fe4d5d861f..f794049568 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -41,12 +41,14 @@ [] (Nothing) (PrefixCon - [({ T14189.hs:6:18-20 } - (HsTyVar - (NoExtField) - (NotPromoted) - ({ T14189.hs:6:18-20 } - {Name: GHC.Types.Int})))]) + [(HsScaled + (HsLinearArrow) + ({ T14189.hs:6:18-20 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T14189.hs:6:18-20 } + {Name: GHC.Types.Int}))))]) (Nothing))) ,({ T14189.hs:6:24-25 } (ConDeclH98 diff --git a/testsuite/tests/polykinds/T6002.hs b/testsuite/tests/polykinds/T6002.hs index 5a1b0edd3e..f8bf2219bb 100644 --- a/testsuite/tests/polykinds/T6002.hs +++ b/testsuite/tests/polykinds/T6002.hs @@ -6,7 +6,7 @@ - phantom types (when GHC 7.4 arrives, the user-defined kinds) - corresponding singleton types -These are basically the constructs from Omega, +These are basically the constructs from Many, reimplemented in Haskell for our purposes. -} {-# LANGUAGE GADTs, KindSignatures, StandaloneDeriving, diff --git a/testsuite/tests/printer/T18052a.stderr b/testsuite/tests/printer/T18052a.stderr index 99aa8b033f..90eea5bb5a 100644 --- a/testsuite/tests/printer/T18052a.stderr +++ b/testsuite/tests/printer/T18052a.stderr @@ -11,12 +11,12 @@ Dependent packages: [base-4.15.0.0, ghc-prim-0.6.1, ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 18, types: 53, coercions: 0, joins: 0/0} + = {terms: 24, types: 61, coercions: 0, joins: 0/0} --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +-- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0} T18052a.$b:||: :: forall {a} {b}. a -> b -> (a, b) [GblId, Arity=2, Unf=OtherCon []] -T18052a.$b:||: = GHC.Tuple.(,) +T18052a.$b:||: = \ (@a) (@b) (x :: a) (y :: b) -> (x, y) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} (+++) :: forall {a}. [a] -> [a] -> [a] diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index 5004d1aacc..8b55b600a5 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -1,19 +1,20 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 98, types: 38, coercions: 5, joins: 0/0} + = {terms: 98, types: 38, coercions: 6, joins: 0/0} -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} convert1 :: Wrap Age -> Wrap Age [GblId, Arity=1, Unf=OtherCon []] convert1 = \ (ds :: Wrap Age) -> ds --- RHS size: {terms: 1, types: 0, coercions: 5, joins: 0/0} +-- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0} convert :: Wrap Age -> Int [GblId, Arity=1, Unf=OtherCon []] convert = convert1 - `cast` (<Wrap Age>_R ->_R Roles13.N:Wrap[0] (Roles13.N:Age[0]) + `cast` (<Wrap Age>_R + # <'Many>_N ->_R Roles13.N:Wrap[0] (Roles13.N:Age[0]) :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int)) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index 8d6f2931cd..7b5547efe7 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -129,9 +129,9 @@ Rule fired: Class op fmap (BUILTIN) ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 52, types: 106, coercions: 15, joins: 0/1} + = {terms: 52, types: 106, coercions: 17, joins: 0/1} --- RHS size: {terms: 37, types: 87, coercions: 15, joins: 0/1} +-- RHS size: {terms: 37, types: 87, coercions: 17, joins: 0/1} mapMaybeRule :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) [GblId, @@ -164,7 +164,7 @@ mapMaybeRule } } }) - `cast` <Co:11>) + `cast` <Co:13>) } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index ac8cb0b275..14c7c957de 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,4 +1,4 @@ [HasNoCafRefs, LambdaFormInfo: LFReEntrant 1, Arity: 1, Strictness: <S,1*U>, Unfolding: InlineRule (0, True, True) - bof `cast` (Sym (N:Foo[0]) ->_R <T>_R)] + bof `cast` (Sym (N:Foo[0]) # <'Many>_N ->_R <T>_R)] diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 9caaa16ff1..67d03b746e 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -4,7 +4,7 @@ Result size of Tidy Core = {terms: 106, types: 47, coercions: 0, joins: 0/0} -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} -T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int -> Foo +T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int #-> Foo [GblId[DataConWrapper], Arity=1, Caf=NoCafRefs, diff --git a/testsuite/tests/stranal/should_compile/T16029.stdout b/testsuite/tests/stranal/should_compile/T16029.stdout index 100b0791ca..77957255c8 100644 --- a/testsuite/tests/stranal/should_compile/T16029.stdout +++ b/testsuite/tests/stranal/should_compile/T16029.stdout @@ -1,4 +1,4 @@ -T16029.$WMkT [InlPrag=INLINE[final] CONLIKE] :: Int -> Int -> T +T16029.$WMkT [InlPrag=INLINE[final] CONLIKE] :: Int #-> Int #-> T Tmpl= \ (dt [Occ=Once!] :: Int) (dt [Occ=Once!] :: Int) -> = \ (dt [Occ=Once!] :: Int) (dt [Occ=Once!] :: Int) -> :: GHC.Prim.Int# -> GHC.Prim.Int# diff --git a/testsuite/tests/th/T10019.stdout b/testsuite/tests/th/T10019.stdout index fb87a9bd9a..6acec6d98f 100644 --- a/testsuite/tests/th/T10019.stdout +++ b/testsuite/tests/th/T10019.stdout @@ -1 +1 @@ -"Constructor from Ghci1.Option: Ghci1.Some :: forall (a_0 :: *) .\n a_0 -> Ghci1.Option a_0" +"Constructor from Ghci1.Option: Ghci1.Some :: forall (a_0 :: *) .\n a_0 #-> Ghci1.Option a_0" diff --git a/testsuite/tests/th/T11345.stdout b/testsuite/tests/th/T11345.stdout index 1230c63897..f710d847c8 100644 --- a/testsuite/tests/th/T11345.stdout +++ b/testsuite/tests/th/T11345.stdout @@ -3,8 +3,8 @@ data Main.GADT (a_0 :: *) where GHC.Types.Int -> Main.GADT GHC.Types.Int (Main.:***:) :: GHC.Types.Int -> GHC.Types.Int -> Main.GADT GHC.Types.Int -Constructor from Main.GADT: (Main.:***:) :: GHC.Types.Int -> - GHC.Types.Int -> Main.GADT GHC.Types.Int +Constructor from Main.GADT: (Main.:***:) :: GHC.Types.Int #-> + GHC.Types.Int #-> Main.GADT GHC.Types.Int Nothing Just (Fixity 7 InfixR) 1 :****: 4 diff --git a/testsuite/tests/th/T14888.stderr b/testsuite/tests/th/T14888.stderr index 4df1e669dc..f58d0c8b45 100644 --- a/testsuite/tests/th/T14888.stderr +++ b/testsuite/tests/th/T14888.stderr @@ -7,4 +7,4 @@ T14888.hs:18:22-60: Splicing expression "class T14888.Functor' (f_0 :: * -> *) where T14888.fmap' :: forall (a_1 :: *) (b_2 :: *) . (a_1 -> b_2) -> f_0 a_1 -> f_0 b_2 -instance T14888.Functor' ((->) r_3 :: * -> *)" +instance T14888.Functor' ((->) r_3)" diff --git a/testsuite/tests/th/TH_reifyLinear.hs b/testsuite/tests/th/TH_reifyLinear.hs new file mode 100644 index 0000000000..c551ad9235 --- /dev/null +++ b/testsuite/tests/th/TH_reifyLinear.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +module TH_reifyLinear where + +import Language.Haskell.TH +import System.IO + +type T = Int #-> Int + +$( + do x <- reify ''T + runIO $ hPutStrLn stderr $ pprint x + return [] + ) diff --git a/testsuite/tests/th/TH_reifyLinear.stderr b/testsuite/tests/th/TH_reifyLinear.stderr new file mode 100644 index 0000000000..ed7866bfa8 --- /dev/null +++ b/testsuite/tests/th/TH_reifyLinear.stderr @@ -0,0 +1 @@ +type TH_reifyLinear.T = GHC.Types.Int #-> GHC.Types.Int diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 46fbcf7073..bd279e1128 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -64,6 +64,7 @@ test('TH_spliceD2', [], multimod_compile, ['TH_spliceD2', '-v0']) test('TH_reifyDecl1', normal, compile, ['-v0']) test('TH_reifyDecl2', normal, compile, ['-v0']) +test('TH_reifyLinear', normal, compile, ['-v0']) test('TH_reifyLocalDefs', normal, compile, ['-v0']) test('TH_reifyLocalDefs2', normal, compile, ['-v0']) diff --git a/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr index 119c6b91e5..8182d7c992 100644 --- a/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr @@ -36,10 +36,6 @@ abstract_refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] where const :: forall a b. a -> b -> a ($) (_ :: [Integer] -> Integer) where ($) :: forall a b. (a -> b) -> a -> b - return (_ :: Integer) - where return :: forall (m :: * -> *) a. Monad m => a -> m a - pure (_ :: Integer) - where pure :: forall (f :: * -> *) a. Applicative f => a -> f a ($!) (_ :: [Integer] -> Integer) where ($!) :: forall a b. (a -> b) -> a -> b curry (_ :: (t0, [Integer]) -> Integer) (_ :: t0) @@ -48,6 +44,10 @@ abstract_refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] where (.) :: forall b c a. (b -> c) -> (a -> b) -> a -> c flip (_ :: [Integer] -> t0 -> Integer) (_ :: t0) where flip :: forall a b c. (a -> b -> c) -> b -> a -> c + return (_ :: Integer) + where return :: forall (m :: * -> *) a. Monad m => a -> m a + pure (_ :: Integer) + where pure :: forall (f :: * -> *) a. Applicative f => a -> f a (>>=) (_ :: [Integer] -> a8) (_ :: a8 -> [Integer] -> Integer) where (>>=) :: forall (m :: * -> *) a b. Monad m => @@ -114,14 +114,14 @@ abstract_refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] where seq :: forall a b. a -> b -> b ($) (_ :: t0 -> [Integer] -> Integer) (_ :: t0) where ($) :: forall a b. (a -> b) -> a -> b - return (_ :: [Integer] -> Integer) (_ :: t0) - where return :: forall (m :: * -> *) a. Monad m => a -> m a - pure (_ :: [Integer] -> Integer) (_ :: t0) - where pure :: forall (f :: * -> *) a. Applicative f => a -> f a uncurry (_ :: a3 -> b3 -> [Integer] -> Integer) (_ :: (a3, b3)) where uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c ($!) (_ :: t0 -> [Integer] -> Integer) (_ :: t0) where ($!) :: forall a b. (a -> b) -> a -> b + return (_ :: [Integer] -> Integer) (_ :: t0) + where return :: forall (m :: * -> *) a. Monad m => a -> m a + pure (_ :: [Integer] -> Integer) (_ :: t0) + where pure :: forall (f :: * -> *) a. Applicative f => a -> f a abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Integer -> [Integer] -> Integer @@ -152,10 +152,6 @@ abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] where const :: forall a b. a -> b -> a ($) (_ :: Integer -> [Integer] -> Integer) where ($) :: forall a b. (a -> b) -> a -> b - return (_ :: [Integer] -> Integer) - where return :: forall (m :: * -> *) a. Monad m => a -> m a - pure (_ :: [Integer] -> Integer) - where pure :: forall (f :: * -> *) a. Applicative f => a -> f a ($!) (_ :: Integer -> [Integer] -> Integer) where ($!) :: forall a b. (a -> b) -> a -> b curry (_ :: (t0, Integer) -> [Integer] -> Integer) (_ :: t0) @@ -164,6 +160,10 @@ abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] where (.) :: forall b c a. (b -> c) -> (a -> b) -> a -> c flip (_ :: Integer -> t0 -> [Integer] -> Integer) (_ :: t0) where flip :: forall a b c. (a -> b -> c) -> b -> a -> c + return (_ :: [Integer] -> Integer) + where return :: forall (m :: * -> *) a. Monad m => a -> m a + pure (_ :: [Integer] -> Integer) + where pure :: forall (f :: * -> *) a. Applicative f => a -> f a (>>=) (_ :: Integer -> a8) (_ :: a8 -> Integer -> [Integer] -> Integer) where (>>=) :: forall (m :: * -> *) a b. @@ -234,12 +234,12 @@ abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] where seq :: forall a b. a -> b -> b ($) (_ :: t0 -> Integer -> [Integer] -> Integer) (_ :: t0) where ($) :: forall a b. (a -> b) -> a -> b - return (_ :: Integer -> [Integer] -> Integer) (_ :: t0) - where return :: forall (m :: * -> *) a. Monad m => a -> m a - pure (_ :: Integer -> [Integer] -> Integer) (_ :: t0) - where pure :: forall (f :: * -> *) a. Applicative f => a -> f a uncurry (_ :: a3 -> b3 -> Integer -> [Integer] -> Integer) (_ :: (a3, b3)) where uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c ($!) (_ :: t0 -> Integer -> [Integer] -> Integer) (_ :: t0) where ($!) :: forall a b. (a -> b) -> a -> b + return (_ :: Integer -> [Integer] -> Integer) (_ :: t0) + where return :: forall (m :: * -> *) a. Monad m => a -> m a + pure (_ :: Integer -> [Integer] -> Integer) (_ :: t0) + where pure :: forall (f :: * -> *) a. Applicative f => a -> f a diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index b4ac6c9916..8d7c1f573f 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -386,7 +386,7 @@ test('holes2', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits - test('holes3', normalise_version('base'), compile_fail, ['-fno-max-valid-hole-fits -funclutter-valid-hole-fits']) test('hole_constraints', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits -funclutter-valid-hole-fits']) test('hole_constraints_nested', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits -funclutter-valid-hole-fits']) -test('valid_hole_fits', [extra_files(['ValidHoleFits.hs'])], +test('valid_hole_fits', extra_files(['ValidHoleFits.hs']), multimod_compile, ['valid_hole_fits','-fdefer-type-errors -fno-max-valid-hole-fits']) test('local_hole_fits', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits']) test('subsumption_sort_hole_fits', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits -fsort-by-subsumption-hole-fits']) diff --git a/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr index 233f8e23d2..adb507ea92 100644 --- a/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr @@ -37,12 +37,12 @@ constraint_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] where const :: forall a b. a -> b -> a ($) (_ :: [a] -> a) where ($) :: forall a b. (a -> b) -> a -> b + ($!) (_ :: [a] -> a) + where ($!) :: forall a b. (a -> b) -> a -> b return (_ :: a) where return :: forall (m :: * -> *) a. Monad m => a -> m a pure (_ :: a) where pure :: forall (f :: * -> *) a. Applicative f => a -> f a - ($!) (_ :: [a] -> a) - where ($!) :: forall a b. (a -> b) -> a -> b id (_ :: [a] -> a) where id :: forall a. a -> a head (_ :: [[a] -> a]) diff --git a/testsuite/tests/typecheck/should_compile/holes.stderr b/testsuite/tests/typecheck/should_compile/holes.stderr index 9f4422909f..77a6fc9a40 100644 --- a/testsuite/tests/typecheck/should_compile/holes.stderr +++ b/testsuite/tests/typecheck/should_compile/holes.stderr @@ -54,6 +54,8 @@ holes.hs:11:15: warning: [-Wtyped-holes (in -Wdefault)] LT :: Ordering EQ :: Ordering GT :: Ordering + One :: GHC.Types.Multiplicity + Many :: GHC.Types.Multiplicity () :: () lines :: String -> [String] unlines :: [String] -> String diff --git a/testsuite/tests/typecheck/should_compile/holes3.stderr b/testsuite/tests/typecheck/should_compile/holes3.stderr index fe6aaf391e..874fd4459f 100644 --- a/testsuite/tests/typecheck/should_compile/holes3.stderr +++ b/testsuite/tests/typecheck/should_compile/holes3.stderr @@ -57,6 +57,8 @@ holes3.hs:11:15: error: LT :: Ordering EQ :: Ordering GT :: Ordering + One :: GHC.Types.Multiplicity + Many :: GHC.Types.Multiplicity () :: () lines :: String -> [String] unlines :: [String] -> String diff --git a/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr index 51e29fd3a2..9e97fb51ff 100644 --- a/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr @@ -71,6 +71,11 @@ refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] with ($) @'GHC.Types.LiftedRep @[Integer] @Integer (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) + ($!) (_ :: [Integer] -> Integer) + where ($!) :: forall a b. (a -> b) -> a -> b + with ($!) @'GHC.Types.LiftedRep @[Integer] @Integer + (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 + (and originally defined in ‘GHC.Base’)) return (_ :: Integer) where return :: forall (m :: * -> *) a. Monad m => a -> m a with return @((->) [Integer]) @Integer @@ -81,11 +86,6 @@ refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] with pure @((->) [Integer]) @Integer (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) - ($!) (_ :: [Integer] -> Integer) - where ($!) :: forall a b. (a -> b) -> a -> b - with ($!) @'GHC.Types.LiftedRep @[Integer] @Integer - (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 - (and originally defined in ‘GHC.Base’)) id (_ :: [Integer] -> Integer) where id :: forall a. a -> a with id @([Integer] -> Integer) @@ -167,6 +167,11 @@ refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] with ($) @'GHC.Types.LiftedRep @Integer @([Integer] -> Integer) (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) + ($!) (_ :: Integer -> [Integer] -> Integer) + where ($!) :: forall a b. (a -> b) -> a -> b + with ($!) @'GHC.Types.LiftedRep @Integer @([Integer] -> Integer) + (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 + (and originally defined in ‘GHC.Base’)) return (_ :: [Integer] -> Integer) where return :: forall (m :: * -> *) a. Monad m => a -> m a with return @((->) Integer) @([Integer] -> Integer) @@ -177,11 +182,6 @@ refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] with pure @((->) Integer) @([Integer] -> Integer) (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) - ($!) (_ :: Integer -> [Integer] -> Integer) - where ($!) :: forall a b. (a -> b) -> a -> b - with ($!) @'GHC.Types.LiftedRep @Integer @([Integer] -> Integer) - (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 - (and originally defined in ‘GHC.Base’)) id (_ :: Integer -> [Integer] -> Integer) where id :: forall a. a -> a with id @(Integer -> [Integer] -> Integer) diff --git a/testsuite/tests/typecheck/should_fail/T17021.stderr b/testsuite/tests/typecheck/should_fail/T17021.stderr index 712858b19f..12d6d687d8 100644 --- a/testsuite/tests/typecheck/should_fail/T17021.stderr +++ b/testsuite/tests/typecheck/should_fail/T17021.stderr @@ -1,14 +1,6 @@ T17021.hs:18:5: error: - Cannot use function with levity-polymorphic arguments: - T17021.MkT :: Int -> T - (Note that levity-polymorphic primops such as 'coerce' and unboxed tuples - are eta-expanded internally because they must occur fully saturated. - Use -fprint-typechecker-elaboration to display the full expression.) - Levity-polymorphic arguments: Int :: TYPE (Id 'LiftedRep) - -T17021.hs:18:9: error: A levity-polymorphic type is not allowed here: Type: Int Kind: TYPE (Id 'LiftedRep) - In the type of expression: 42 + When trying to create a variable of type: Int diff --git a/testsuite/tests/typecheck/should_fail/UnliftedNewtypesLevityBinder.stderr b/testsuite/tests/typecheck/should_fail/UnliftedNewtypesLevityBinder.stderr index 70746fd60a..a33a957e9d 100644 --- a/testsuite/tests/typecheck/should_fail/UnliftedNewtypesLevityBinder.stderr +++ b/testsuite/tests/typecheck/should_fail/UnliftedNewtypesLevityBinder.stderr @@ -1,8 +1,6 @@ UnliftedNewtypesLevityBinder.hs:16:7: error: - Cannot use function with levity-polymorphic arguments: - IdentC :: a -> Ident a - (Note that levity-polymorphic primops such as 'coerce' and unboxed tuples - are eta-expanded internally because they must occur fully saturated. - Use -fprint-typechecker-elaboration to display the full expression.) - Levity-polymorphic arguments: a :: TYPE r + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE r + When trying to create a variable of type: a diff --git a/testsuite/tests/typecheck/should_run/T14236.stdout b/testsuite/tests/typecheck/should_run/T14236.stdout index a168ea8d04..ffa0e65dc9 100644 --- a/testsuite/tests/typecheck/should_run/T14236.stdout +++ b/testsuite/tests/typecheck/should_run/T14236.stdout @@ -1,3 +1,3 @@ -((->) 'LiftedRep 'LiftedRep Int,Char) -((->) 'IntRep 'LiftedRep Int#,Char) +(FUN 'Many 'LiftedRep 'LiftedRep Int,Char) +(FUN 'Many 'IntRep 'LiftedRep Int#,Char) Int# -> [Char] diff --git a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout index 515738e98e..7769b78eb9 100644 --- a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout +++ b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout @@ -5,7 +5,7 @@ good: Maybe good: TYPE good: RuntimeRep good: 'IntRep -good: (->) 'LiftedRep 'LiftedRep +good: FUN 'Many 'LiftedRep 'LiftedRep good: Proxy * Int good: Proxy (TYPE 'IntRep) Int# good: * diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 576dbc9a20..31d363c0fa 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -928,8 +928,8 @@ ppType (TyApp (VecTyCon _ pptc) []) = pptc ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ listify (map ppType ts) ++ ")" -ppType (TyF s d) = "(mkVisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" -ppType (TyC s d) = "(mkInvisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" +ppType (TyF s d) = "(mkVisFunTyMany (" ++ ppType s ++ ") (" ++ ppType d ++ "))" +ppType (TyC s d) = "(mkInvisFunTyMany (" ++ ppType s ++ ") (" ++ ppType d ++ "))" ppType other = error ("ppType: can't handle: " ++ show other ++ "\n") diff --git a/utils/haddock b/utils/haddock -Subproject e37911553bfe6804d3903f750261f758569b4a2 +Subproject 02a1def8d147da88a0433726590f8586f486c76 |