Commit 40fa237e authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Ben Gamari

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.
parent 20616959
......@@ -197,7 +197,7 @@ module GHC (
-- ** Data constructors
DataCon,
dataConType, dataConTyCon, dataConFieldLabels,
dataConIsInfix, isVanillaDataCon, dataConUserType,
dataConIsInfix, isVanillaDataCon, dataConWrapperType,
dataConSrcBangs,
StrictnessMark(..), isMarkedStrict,
......
......@@ -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
-----------------------------------------------------
......
......@@ -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
......
......@@ -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:
......
This diff is collapsed.
......@@ -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
......@@ -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]
{-
************************************************************************
* *
......
......@@ -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#"
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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 = \_ _ _ _ -> []
}
......@@ -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]
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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]
......
......@@ -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
......
This diff is collapsed.
......@@ -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