diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -12,7 +12,7 @@ /* Useful in the headers that we share with the RTS */ #define COMPILING_GHC 1 -/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */ +/* Pull in all the platform defines for this build (foo_HOST_ARCH etc.) */ #include "ghc_boot_platform.h" /* Pull in the autoconf defines (HAVE_FOO), but don't include diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs --- a/compiler/basicTypes/NameSet.hs +++ b/compiler/basicTypes/NameSet.hs @@ -36,6 +36,7 @@ import GhcPrelude import Name +import OrdList import UniqSet import Data.List (sortBy) @@ -160,19 +161,19 @@ -- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' -- In a single (def, use) pair, the defs also scope over the uses -type DefUses = [DefUse] +type DefUses = OrdList DefUse emptyDUs :: DefUses -emptyDUs = [] +emptyDUs = nilOL usesOnly :: Uses -> DefUses -usesOnly uses = [(Nothing, uses)] +usesOnly uses = unitOL (Nothing, uses) mkDUs :: [(Defs,Uses)] -> DefUses -mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] +mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] plusDU :: DefUses -> DefUses -> DefUses -plusDU = (++) +plusDU = appOL duDefs :: DefUses -> Defs duDefs dus = foldr get emptyNameSet dus diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -89,7 +89,8 @@ import GhcPrelude -import {-# SOURCE #-} TyCoRep( Type, Kind, pprKind ) +import {-# SOURCE #-} TyCoRep( Type, Kind ) +import {-# SOURCE #-} TyCoPpr( pprKind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -98,10 +98,13 @@ -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides -- the motivation for this abstraction. data InScopeSet = InScope VarSet {-# UNPACK #-} !Int - -- We store a VarSet here, but we use this for lookups rather than - -- just membership tests. Typically the InScopeSet contains the - -- canonical version of the variable (e.g. with an informative - -- unfolding), so this lookup is useful. + -- Note [Lookups in in-scope set] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We store a VarSet here, but we use this for lookups rather than just + -- membership tests. Typically the InScopeSet contains the canonical + -- version of the variable (e.g. with an informative unfolding), so this + -- lookup is useful (see, for instance, Note [In-scope set as a + -- substitution]). -- -- The Int is a kind of hash-value used by uniqAway -- For example, it might be the size of the set diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -6,7 +6,6 @@ , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood , isFloatType, isGcPtrType, isBitsType , isWord32, isWord64, isFloat64, isFloat32 - , isVecCatType , Width(..) , widthInBits, widthInBytes, widthInLog, widthFromBytes @@ -134,7 +133,7 @@ cInt dflags = cmmBits (cIntWidth dflags) ------------ Predicates ---------------- -isFloatType, isGcPtrType, isBitsType, isVecCatType :: CmmType -> Bool +isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool isFloatType (CmmType FloatCat _) = True isFloatType _other = False @@ -143,9 +142,6 @@ isBitsType (CmmType BitsCat _) = True isBitsType _ = False - -isVecCatType (CmmType (VecCat _ _) _) = True -isVecCatType _other = False isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool -- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -1055,10 +1055,17 @@ where empty_subst = mkEmptyTCvSubst in_scope + go :: Arity -- Number of value args to expand to + -> TCvSubst -> Type -- We are really looking at subst(ty) + -> [EtaInfo] -- Accumulating parameter + -> (InScopeSet, [EtaInfo]) go n subst ty eis -- See Note [exprArity invariant] + + ----------- Done! No more expansion needed | n == 0 = (getTCvInScope subst, reverse eis) + ----------- Forall types (forall a. ty) | Just (tcv,ty') <- splitForAllTy_maybe ty , let (subst', tcv') = Type.substVarBndr subst tcv = let ((n_subst, n_tcv), n_n) @@ -1069,10 +1076,11 @@ -- 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' (varType 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) -- See Note [Levity polymorphism invariants] in CoreSyn @@ -1082,14 +1090,19 @@ -- Avoid free vars of the original expression = go (n-1) subst' res_ty (EtaVar eta_id' : eis) + ----------- Newtypes + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) | Just (co, ty') <- topNormaliseNewType_maybe ty - = -- Given this: - -- newtype T = MkT ([T] -> Int) - -- Consider eta-expanding this - -- eta_expand 1 e T - -- We want to get - -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - go n subst ty' (pushCoercion co eis) + , let co' = Coercion.substCo subst co + -- Remember to apply the substitution to co (#16979) + -- (or we could have applied to ty, but then + -- we'd have had to zap it for the recursive call) + = go n subst ty' (pushCoercion co' eis) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -72,6 +72,7 @@ import Var import Type import TyCoRep +import TyCoFVs import TyCon import CoAxiom import FamInstEnv diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -312,11 +312,17 @@ -- The let might appear there as a result of inlining -- e.g. let f = let x = e in b -- in f a1 a2 --- (#13208) -simple_app env (Let bind body) as +-- (#13208) +-- However, do /not/ do this transformation for join points +-- See Note [simple_app and join points] +simple_app env (Let bind body) args = case simple_opt_bind env bind of - (env', Nothing) -> simple_app env' body as - (env', Just bind) -> Let bind (simple_app env' body as) + (env', Nothing) -> simple_app env' body args + (env', Just bind') + | isJoinBind bind' -> finish_app env expr' args + | otherwise -> Let bind' (simple_app env' body args) + where + expr' = Let bind' (simple_opt_expr env' body) simple_app env e as = finish_app env (simple_opt_expr env e) as @@ -494,6 +500,34 @@ the RHS with simple_opt_expr, which does eta-reduction. Solution: simplify the RHS of a join point by simplifying under the lambdas (which of course should be there). + +Note [simple_app and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general for let-bindings we can do this: + (let { x = e } in b) a ==> let { x = e } in b a + +But not for join points! For two reasons: + +- We would need to push the continuation into the RHS: + (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a + NB ----^^ + and also change the type of j, hence j'. + That's a bit sophisticated for the very simple optimiser. + +- We might end up with something like + join { j' = e a } in + (case blah of ) + ( True -> j' void# ) a + ( False -> blah ) + and now the call to j' doesn't look like a tail call, and + Lint may reject. I say "may" because this is /explicitly/ + allowed in the "Compiling without Continuations" paper + (Section 3, "Managing \Delta"). But GHC currently does not + allow this slightly-more-flexible form. See CoreSyn + Note [Join points are less general than the paper]. + +The simple thing to do is to disable this transformation +for join points in the simple optimiser -} ---------------------- diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -79,9 +79,9 @@ -- -- Some invariants apply to how you use the substitution: -- --- 1. Note [The substitution invariant] in TyCoRep +-- 1. Note [The substitution invariant] in TyCoSubst -- --- 2. Note [Substitutions apply only once] in TyCoRep +-- 2. Note [Substitutions apply only once] in TyCoSubst data Subst = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ -- applying the substitution @@ -89,7 +89,7 @@ TvSubstEnv -- Substitution from TyVars to Types CvSubstEnv -- Substitution from CoVars to Coercions - -- INVARIANT 1: See TyCoRep Note [The substitution invariant] + -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] -- This is what lets us deal with name capture properly -- It's a hard invariant to check... -- @@ -104,7 +104,7 @@ For a core Subst, which binds Ids as well, we make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] with Type.TvSubstEnv +For TyVars, see Note [Extending the TCvSubst] in TyCoSubst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -171,7 +171,7 @@ mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs --- | Find the in-scope set: see TyCoRep Note [The substitution invariant] +-- | Find the in-scope set: see TyCoSubst Note [The substitution invariant] substInScope :: Subst -> InScopeSet substInScope (Subst in_scope _ _ _) = in_scope @@ -181,7 +181,7 @@ zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is --- such that TyCoRep Note [The substitution invariant] +-- such that TyCoSubst Note [The substitution invariant] -- holds after extending the substitution like this extendIdSubst :: Subst -> Id -> CoreExpr -> Subst -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set @@ -198,7 +198,7 @@ -- | Add a substitution for a 'TyVar' to the 'Subst' -- The 'TyVar' *must* be a real TyVar, and not a CoVar -- You must ensure that the in-scope set is such that --- TyCoRep Note [The substitution invariant] holds +-- TyCoSubst Note [The substitution invariant] holds -- after extending the substitution like this. extendTvSubst :: Subst -> TyVar -> Type -> Subst extendTvSubst (Subst in_scope ids tvs cvs) tv ty @@ -214,7 +214,7 @@ -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': -- you must ensure that the in-scope set satisfies --- TyCoRep Note [The substitution invariant] +-- TyCoSubst Note [The substitution invariant] -- after extending the substitution like this extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r @@ -339,7 +339,7 @@ -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only -- apply the substitution /once/: --- see Note [Substitutions apply only once] in TyCoRep +-- See Note [Substitutions apply only once] in TyCoSubst -- -- Do *not* attempt to short-cut in the case of an empty substitution! -- See Note [Extending the Subst] diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -608,6 +608,8 @@ same number of arguments, counting both types and values; we call this the "join arity" (to distinguish from regular arity, which only counts values). + See Note [Join points are less general than the paper] + 2. For join arity n, the right-hand side must begin with at least n lambdas. No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. @@ -656,6 +658,26 @@ Core Lint will check these invariants, anticipating that any binder whose OccInfo is marked AlwaysTailCalled will become a join point as soon as the simplifier (or simpleOptPgm) runs. + +Note [Join points are less general than the paper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the paper "Compiling without continuations", this expression is +perfectly valid: + + join { j = \_ -> e } + in (case blah of ) + ( True -> j void# ) arg + ( False -> blah ) + +assuming 'j' has arity 1. Here the call to 'j' does not look like a +tail call, but actually everything is fine. See Section 3, "Managing \Delta" +in the paper. + +In GHC, however, we adopt a slightly more restrictive subset, in which +join point calls must be tail calls. I think we /could/ loosen it up, but +in fact the simplifier ensures that we always get tail calls, and it makes +the back end a bit easier I think. Generally, just less to think about; +nothing deeper than that. Note [The type of a join point] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -35,6 +35,7 @@ import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import Data.Maybe (catMaybes) import GHC.Exts.Heap import GHC.Stack.CCS @@ -110,14 +111,15 @@ -- | Information about a breakpoint that we know at code-generation time data CgBreakInfo = CgBreakInfo - { cgb_vars :: [(Id,Word16)] + { cgb_vars :: [Maybe (Id,Word16)] , cgb_resty :: Type } +-- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs -- Not a real NFData instance because we can't rnf Id or Type seqCgBreakInfo :: CgBreakInfo -> () seqCgBreakInfo CgBreakInfo{..} = - rnf (map snd cgb_vars) `seq` + rnf (map snd (catMaybes (cgb_vars))) `seq` seqType cgb_resty instance Outputable UnlinkedBCO where diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -94,10 +94,10 @@ | XHsLocalBindsLR (XXHsLocalBindsLR idL idR) -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt -type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt -type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) @@ -135,7 +135,7 @@ [(RecFlag, LHsBinds idL)] [LSig GhcRn] -type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXValBindsLR (GhcPass pL) (GhcPass pR) = NHsValBindsLR (GhcPass pL) @@ -319,18 +319,18 @@ pat_rhs_ty :: Type -- ^ Type of the GRHSs } deriving Data -type instance XFunBind (GhcPass pL) GhcPs = NoExt +type instance XFunBind (GhcPass pL) GhcPs = NoExtField type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables -type instance XPatBind GhcPs (GhcPass pR) = NoExt +type instance XPatBind GhcPs (GhcPass pR) = NoExtField type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc -type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt -type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt -type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt -type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt +type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] @@ -356,8 +356,8 @@ } | XABExport (XXABExport p) -type instance XABE (GhcPass p) = NoExt -type instance XXABExport (GhcPass p) = NoExt +type instance XABE (GhcPass p) = NoExtField +type instance XXABExport (GhcPass p) = NoExtCon -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', @@ -379,11 +379,11 @@ } | XPatSynBind (XXPatSynBind idL idR) -type instance XPSB (GhcPass idL) GhcPs = NoExt +type instance XPSB (GhcPass idL) GhcPs = NoExtField type instance XPSB (GhcPass idL) GhcRn = NameSet type instance XPSB (GhcPass idL) GhcTc = NameSet -type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon {- Note [AbsBinds] @@ -682,7 +682,7 @@ ------------ emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -emptyLocalBinds = EmptyLocalBinds noExt +emptyLocalBinds = EmptyLocalBinds noExtField -- AZ:These functions do not seem to be used at all? isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool @@ -706,7 +706,7 @@ isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds noExt emptyBag [] +emptyValBindsIn = ValBinds noExtField emptyBag [] emptyValBindsOut = XValBindsLR (NValBinds [] []) emptyLHsBinds :: LHsBindsLR idL idR @@ -719,7 +719,7 @@ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) + = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) (XValBindsLR (NValBinds ds2 sigs2)) = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) @@ -824,13 +824,13 @@ -- -- uses of the implicit parameters | XHsIPBinds (XXHsIPBinds id) -type instance XIPBinds GhcPs = NoExt -type instance XIPBinds GhcRn = NoExt +type instance XIPBinds GhcPs = NoExtField +type instance XIPBinds GhcRn = NoExtField type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the -- implicit parameters -type instance XXHsIPBinds (GhcPass p) = NoExt +type instance XXHsIPBinds (GhcPass p) = NoExtCon isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool isEmptyIPBindsPR (IPBinds _ is) = null is @@ -864,8 +864,8 @@ (LHsExpr id) | XIPBind (XXIPBind id) -type instance XCIPBind (GhcPass p) = NoExt -type instance XXIPBind (GhcPass p) = NoExt +type instance XCIPBind (GhcPass p) = NoExtField +type instance XXIPBind (GhcPass p) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsIPBinds p) where @@ -1047,18 +1047,18 @@ (Maybe (Located (IdP pass))) | XSig (XXSig pass) -type instance XTypeSig (GhcPass p) = NoExt -type instance XPatSynSig (GhcPass p) = NoExt -type instance XClassOpSig (GhcPass p) = NoExt -type instance XIdSig (GhcPass p) = NoExt -type instance XFixSig (GhcPass p) = NoExt -type instance XInlineSig (GhcPass p) = NoExt -type instance XSpecSig (GhcPass p) = NoExt -type instance XSpecInstSig (GhcPass p) = NoExt -type instance XMinimalSig (GhcPass p) = NoExt -type instance XSCCFunSig (GhcPass p) = NoExt -type instance XCompleteMatchSig (GhcPass p) = NoExt -type instance XXSig (GhcPass p) = NoExt +type instance XTypeSig (GhcPass p) = NoExtField +type instance XPatSynSig (GhcPass p) = NoExtField +type instance XClassOpSig (GhcPass p) = NoExtField +type instance XIdSig (GhcPass p) = NoExtField +type instance XFixSig (GhcPass p) = NoExtField +type instance XInlineSig (GhcPass p) = NoExtField +type instance XSpecSig (GhcPass p) = NoExtField +type instance XSpecInstSig (GhcPass p) = NoExtField +type instance XMinimalSig (GhcPass p) = NoExtField +type instance XSCCFunSig (GhcPass p) = NoExtField +type instance XCompleteMatchSig (GhcPass p) = NoExtField +type instance XXSig (GhcPass p) = NoExtCon -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) @@ -1067,8 +1067,8 @@ data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity | XFixitySig (XXFixitySig pass) -type instance XFixitySig (GhcPass p) = NoExt -type instance XXFixitySig (GhcPass p) = NoExt +type instance XFixitySig (GhcPass p) = NoExtField +type instance XXFixitySig (GhcPass p) = NoExtCon -- | Type checker Specialisation Pragmas -- diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -23,7 +23,7 @@ -- ** Class or type declarations TyClDecl(..), LTyClDecl, DataDeclRn(..), - TyClGroup(..), mkTyClGroup, emptyTyClGroup, + TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, isClassDecl, isDataDecl, isSynDecl, tcdName, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, @@ -47,7 +47,8 @@ -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** Deriving strategies - DerivStrategy(..), LDerivStrategy, derivStrategyName, + DerivStrategy(..), LDerivStrategy, + derivStrategyName, foldDerivStrategy, mapDerivStrategy, -- ** @RULE@ declarations LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), RuleBndr(..),LRuleBndr, @@ -146,20 +147,20 @@ | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration | XHsDecl (XXHsDecl p) -type instance XTyClD (GhcPass _) = NoExt -type instance XInstD (GhcPass _) = NoExt -type instance XDerivD (GhcPass _) = NoExt -type instance XValD (GhcPass _) = NoExt -type instance XSigD (GhcPass _) = NoExt -type instance XDefD (GhcPass _) = NoExt -type instance XForD (GhcPass _) = NoExt -type instance XWarningD (GhcPass _) = NoExt -type instance XAnnD (GhcPass _) = NoExt -type instance XRuleD (GhcPass _) = NoExt -type instance XSpliceD (GhcPass _) = NoExt -type instance XDocD (GhcPass _) = NoExt -type instance XRoleAnnotD (GhcPass _) = NoExt -type instance XXHsDecl (GhcPass _) = NoExt +type instance XTyClD (GhcPass _) = NoExtField +type instance XInstD (GhcPass _) = NoExtField +type instance XDerivD (GhcPass _) = NoExtField +type instance XValD (GhcPass _) = NoExtField +type instance XSigD (GhcPass _) = NoExtField +type instance XDefD (GhcPass _) = NoExtField +type instance XForD (GhcPass _) = NoExtField +type instance XWarningD (GhcPass _) = NoExtField +type instance XAnnD (GhcPass _) = NoExtField +type instance XRuleD (GhcPass _) = NoExtField +type instance XSpliceD (GhcPass _) = NoExtField +type instance XDocD (GhcPass _) = NoExtField +type instance XRoleAnnotD (GhcPass _) = NoExtField +type instance XXHsDecl (GhcPass _) = NoExtCon -- NB: all top-level fixity decls are contained EITHER -- EITHER SigDs @@ -206,8 +207,8 @@ } | XHsGroup (XXHsGroup p) -type instance XCHsGroup (GhcPass _) = NoExt -type instance XXHsGroup (GhcPass _) = NoExt +type instance XCHsGroup (GhcPass _) = NoExtField +type instance XXHsGroup (GhcPass _) = NoExtCon emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) @@ -217,7 +218,7 @@ hsGroupInstDecls :: HsGroup id -> [LInstDecl id] hsGroupInstDecls = (=<<) group_instds . hs_tyclds -emptyGroup = HsGroup { hs_ext = noExt, +emptyGroup = HsGroup { hs_ext = noExtField, hs_tyclds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], @@ -255,7 +256,7 @@ hs_docs = docs2 } = HsGroup { - hs_ext = noExt, + hs_ext = noExtField, hs_valds = val_groups1 `plusHsValBinds` val_groups2, hs_splcds = spliceds1 ++ spliceds2, hs_tyclds = tyclds1 ++ tyclds2, @@ -330,8 +331,8 @@ SpliceExplicitFlag | XSpliceDecl (XXSpliceDecl p) -type instance XSpliceDecl (GhcPass _) = NoExt -type instance XXSpliceDecl (GhcPass _) = NoExt +type instance XSpliceDecl (GhcPass _) = NoExtField +type instance XXSpliceDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (SpliceDecl p) where @@ -576,21 +577,21 @@ Note [Family instance declaration binders] -} -type instance XFamDecl (GhcPass _) = NoExt +type instance XFamDecl (GhcPass _) = NoExtField -type instance XSynDecl GhcPs = NoExt +type instance XSynDecl GhcPs = NoExtField type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs -type instance XDataDecl GhcPs = NoExt +type instance XDataDecl GhcPs = NoExtField type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = NoExt +type instance XClassDecl GhcPs = NoExtField type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs -type instance XXTyClDecl (GhcPass _) = NoExt +type instance XXTyClDecl (GhcPass _) = NoExtCon -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -641,17 +642,17 @@ -- Dealing with names -tyFamInstDeclName :: TyFamInstDecl pass -> (IdP pass) +tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) tyFamInstDeclName = unLoc . tyFamInstDeclLName -tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass) +tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p)) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) = ln -tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _))) - = panic "tyFamInstDeclLName" -tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _)) - = panic "tyFamInstDeclLName" +tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec +tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec tyClDeclLName :: TyClDecl pass -> Located (IdP pass) tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln @@ -699,7 +700,7 @@ _ -> False hsDeclHasCusk _cusks_enabled@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk _cusks_enabled@True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -hsDeclHasCusk _ (XTyClDecl _) = panic "hsDeclHasCusk" +hsDeclHasCusk _ (XTyClDecl nec) = noExtCon nec -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -912,13 +913,10 @@ , group_instds :: [LInstDecl pass] } | XTyClGroup (XXTyClGroup pass) -type instance XCTyClGroup (GhcPass _) = NoExt -type instance XXTyClGroup (GhcPass _) = NoExt +type instance XCTyClGroup (GhcPass _) = NoExtField +type instance XXTyClGroup (GhcPass _) = NoExtCon -emptyTyClGroup :: TyClGroup (GhcPass p) -emptyTyClGroup = TyClGroup noExt [] [] [] - tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] tyClGroupTyClDecls = concatMap group_tyclds @@ -928,17 +926,8 @@ tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] tyClGroupRoleDecls = concatMap group_roles -mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)] - -> TyClGroup (GhcPass p) -mkTyClGroup decls instds = TyClGroup - { group_ext = noExt - , group_tyclds = decls - , group_roles = [] - , group_instds = instds - } - {- ********************************************************************* * * Data and type family declarations @@ -1033,10 +1022,10 @@ -- For details on above see note [Api annotations] in ApiAnnotation -type instance XNoSig (GhcPass _) = NoExt -type instance XCKindSig (GhcPass _) = NoExt -type instance XTyVarSig (GhcPass _) = NoExt -type instance XXFamilyResultSig (GhcPass _) = NoExt +type instance XNoSig (GhcPass _) = NoExtField +type instance XCKindSig (GhcPass _) = NoExtField +type instance XTyVarSig (GhcPass _) = NoExtField +type instance XXFamilyResultSig (GhcPass _) = NoExtCon -- | Located type Family Declaration @@ -1063,8 +1052,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation -type instance XCFamilyDecl (GhcPass _) = NoExt -type instance XXFamilyDecl (GhcPass _) = NoExt +type instance XCFamilyDecl (GhcPass _) = NoExtField +type instance XXFamilyDecl (GhcPass _) = NoExtCon -- | Located Injectivity Annotation @@ -1097,7 +1086,7 @@ famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled -> Bool -- ^ True <=> this is an associated type family, -- and the parent class has /no/ CUSK - -> FamilyDecl pass + -> FamilyDecl (GhcPass pass) -> Bool famDeclHasCusk _cusks_enabled@False _ _ = False famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk @@ -1111,7 +1100,7 @@ -- Un-associated open type/data families have CUSKs -- Associated type families have CUSKs iff the parent class does -famDeclHasCusk _ _ (XFamilyDecl {}) = panic "famDeclHasCusk" +famDeclHasCusk _ _ (XFamilyDecl nec) = noExtCon nec -- | Does this family declaration have user-supplied return kind signature? hasReturnKindSignature :: FamilyResultSig a -> Bool @@ -1120,7 +1109,7 @@ hasReturnKindSignature _ = True -- | Maybe return name of the result type variable -resultVariableName :: FamilyResultSig a -> Maybe (IdP a) +resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing @@ -1213,8 +1202,8 @@ } | XHsDataDefn (XXHsDataDefn pass) -type instance XCHsDataDefn (GhcPass _) = NoExt -type instance XXHsDataDefn (GhcPass _) = NoExt +type instance XCHsDataDefn (GhcPass _) = NoExtField +type instance XXHsDataDefn (GhcPass _) = NoExtCon -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1253,8 +1242,8 @@ } | XHsDerivingClause (XXHsDerivingClause pass) -type instance XCHsDerivingClause (GhcPass _) = NoExt -type instance XXHsDerivingClause (GhcPass _) = NoExt +type instance XCHsDerivingClause (GhcPass _) = NoExtField +type instance XXHsDerivingClause (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDerivingClause p) where @@ -1363,9 +1352,9 @@ } | XConDecl (XXConDecl pass) -type instance XConDeclGADT (GhcPass _) = NoExt -type instance XConDeclH98 (GhcPass _) = NoExt -type instance XXConDecl (GhcPass _) = NoExt +type instance XConDeclGADT (GhcPass _) = NoExtField +type instance XConDeclH98 (GhcPass _) = NoExtField +type instance XXConDecl (GhcPass _) = NoExtCon {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1408,10 +1397,10 @@ type HsConDeclDetails pass = HsConDetails (LBangType pass) (Located [LConDeclField pass]) -getConNames :: ConDecl pass -> [Located (IdP pass)] +getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -getConNames XConDecl {} = panic "getConNames" +getConNames (XConDecl nec) = noExtCon nec getConArgs :: ConDecl pass -> HsConDeclDetails pass getConArgs d = con_args d @@ -1648,8 +1637,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation -type instance XCFamEqn (GhcPass _) r = NoExt -type instance XXFamEqn (GhcPass _) r = NoExt +type instance XCFamEqn (GhcPass _) r = NoExtField +type instance XXFamEqn (GhcPass _) r = NoExtCon ----------------- Class instances ------------- @@ -1681,8 +1670,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation | XClsInstDecl (XXClsInstDecl pass) -type instance XCClsInstDecl (GhcPass _) = NoExt -type instance XXClsInstDecl (GhcPass _) = NoExt +type instance XCClsInstDecl (GhcPass _) = NoExtField +type instance XXClsInstDecl (GhcPass _) = NoExtCon ----------------- Instances of all kinds ------------- @@ -1702,10 +1691,10 @@ , tfid_inst :: TyFamInstDecl pass } | XInstDecl (XXInstDecl pass) -type instance XClsInstD (GhcPass _) = NoExt -type instance XDataFamInstD (GhcPass _) = NoExt -type instance XTyFamInstD (GhcPass _) = NoExt -type instance XXInstDecl (GhcPass _) = NoExt +type instance XClsInstD (GhcPass _) = NoExtField +type instance XDataFamInstD (GhcPass _) = NoExtField +type instance XTyFamInstD (GhcPass _) = NoExtField +type instance XXInstDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyFamInstDecl p) where @@ -1841,7 +1830,7 @@ -- Extract the declarations of associated data types from an instance -instDeclDataFamInsts :: [LInstDecl pass] -> [DataFamInstDecl pass] +instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)] instDeclDataFamInsts inst_decls = concatMap do_one inst_decls where @@ -1849,8 +1838,8 @@ = map unLoc fam_insts do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] - do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts" - do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts" + do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec + do_one (L _ (XInstDecl nec)) = noExtCon nec {- ************************************************************************ @@ -1889,8 +1878,8 @@ } | XDerivDecl (XXDerivDecl pass) -type instance XCDerivDecl (GhcPass _) = NoExt -type instance XXDerivDecl (GhcPass _) = NoExt +type instance XCDerivDecl (GhcPass _) = NoExtField +type instance XXDerivDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DerivDecl p) where @@ -1948,6 +1937,21 @@ go NewtypeStrategy = "newtype" go (ViaStrategy {}) = "via" +-- | Eliminate a 'DerivStrategy'. +foldDerivStrategy :: (p ~ GhcPass pass) + => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r +foldDerivStrategy other _ StockStrategy = other +foldDerivStrategy other _ AnyclassStrategy = other +foldDerivStrategy other _ NewtypeStrategy = other +foldDerivStrategy _ via (ViaStrategy t) = via t + +-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise, +-- return the 'DerivStrategy' unchanged. +mapDerivStrategy :: (p ~ GhcPass pass) + => (XViaStrategy p -> XViaStrategy p) + -> DerivStrategy p -> DerivStrategy p +mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds + {- ************************************************************************ * * @@ -1972,8 +1976,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation | XDefaultDecl (XXDefaultDecl pass) -type instance XCDefaultDecl (GhcPass _) = NoExt -type instance XXDefaultDecl (GhcPass _) = NoExt +type instance XCDefaultDecl (GhcPass _) = NoExtField +type instance XXDefaultDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DefaultDecl p) where @@ -2028,15 +2032,15 @@ such as Int and IO that we know how to make foreign calls with. -} -type instance XForeignImport GhcPs = NoExt -type instance XForeignImport GhcRn = NoExt +type instance XForeignImport GhcPs = NoExtField +type instance XForeignImport GhcRn = NoExtField type instance XForeignImport GhcTc = Coercion -type instance XForeignExport GhcPs = NoExt -type instance XForeignExport GhcRn = NoExt +type instance XForeignExport GhcPs = NoExtField +type instance XForeignExport GhcRn = NoExtField type instance XForeignExport GhcTc = Coercion -type instance XXForeignDecl (GhcPass _) = NoExt +type instance XXForeignDecl (GhcPass _) = NoExtCon -- Specification Of an imported external entity in dependence on the calling -- convention @@ -2143,8 +2147,8 @@ , rds_rules :: [LRuleDecl pass] } | XRuleDecls (XXRuleDecls pass) -type instance XCRuleDecls (GhcPass _) = NoExt -type instance XXRuleDecls (GhcPass _) = NoExt +type instance XCRuleDecls (GhcPass _) = NoExtField +type instance XXRuleDecls (GhcPass _) = NoExtCon -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -2177,11 +2181,11 @@ data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS deriving Data -type instance XHsRule GhcPs = NoExt +type instance XHsRule GhcPs = NoExtField type instance XHsRule GhcRn = HsRuleRn type instance XHsRule GhcTc = HsRuleRn -type instance XXRuleDecl (GhcPass _) = NoExt +type instance XXRuleDecl (GhcPass _) = NoExtCon flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -2200,9 +2204,9 @@ -- For details on above see note [Api annotations] in ApiAnnotation -type instance XCRuleBndr (GhcPass _) = NoExt -type instance XRuleBndrSig (GhcPass _) = NoExt -type instance XXRuleBndr (GhcPass _) = NoExt +type instance XCRuleBndr (GhcPass _) = NoExtField +type instance XRuleBndrSig (GhcPass _) = NoExtField +type instance XXRuleBndr (GhcPass _) = NoExtCon collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] @@ -2290,8 +2294,8 @@ } | XWarnDecls (XXWarnDecls pass) -type instance XWarnings (GhcPass _) = NoExt -type instance XXWarnDecls (GhcPass _) = NoExt +type instance XWarnings (GhcPass _) = NoExtField +type instance XXWarnDecls (GhcPass _) = NoExtCon -- | Located Warning pragma Declaration type LWarnDecl pass = Located (WarnDecl pass) @@ -2300,8 +2304,8 @@ data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt | XWarnDecl (XXWarnDecl pass) -type instance XWarning (GhcPass _) = NoExt -type instance XXWarnDecl (GhcPass _) = NoExt +type instance XWarning (GhcPass _) = NoExtField +type instance XXWarnDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass,OutputableBndr (IdP p)) @@ -2342,8 +2346,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation | XAnnDecl (XXAnnDecl pass) -type instance XHsAnnotation (GhcPass _) = NoExt -type instance XXAnnDecl (GhcPass _) = NoExt +type instance XHsAnnotation (GhcPass _) = NoExtField +type instance XXAnnDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where ppr (HsAnnotation _ _ provenance expr) @@ -2395,8 +2399,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation | XRoleAnnotDecl (XXRoleAnnotDecl pass) -type instance XCRoleAnnotDecl (GhcPass _) = NoExt -type instance XXRoleAnnotDecl (GhcPass _) = NoExt +type instance XCRoleAnnotDecl (GhcPass _) = NoExtField +type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndr (IdP p)) => Outputable (RoleAnnotDecl p) where @@ -2408,6 +2412,6 @@ pp_role (Just r) = ppr r ppr (XRoleAnnotDecl x) = ppr x -roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass) +roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name -roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName" +roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -110,13 +110,14 @@ -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p) -noExpr = HsLit noExt (HsString (SourceText "noExpr") (fsLit "noExpr")) +noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) noSyntaxExpr :: SyntaxExpr (GhcPass p) -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString NoSourceText - (fsLit "noSyntaxExpr")) +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField + (HsString NoSourceText + (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } @@ -129,7 +130,7 @@ -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExt $ noLoc name +mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker @@ -659,84 +660,84 @@ -- --------------------------------------------------------------------- -type instance XVar (GhcPass _) = NoExt -type instance XUnboundVar (GhcPass _) = NoExt -type instance XConLikeOut (GhcPass _) = NoExt -type instance XRecFld (GhcPass _) = NoExt -type instance XOverLabel (GhcPass _) = NoExt -type instance XIPVar (GhcPass _) = NoExt -type instance XOverLitE (GhcPass _) = NoExt -type instance XLitE (GhcPass _) = NoExt -type instance XLam (GhcPass _) = NoExt -type instance XLamCase (GhcPass _) = NoExt -type instance XApp (GhcPass _) = NoExt +type instance XVar (GhcPass _) = NoExtField +type instance XUnboundVar (GhcPass _) = NoExtField +type instance XConLikeOut (GhcPass _) = NoExtField +type instance XRecFld (GhcPass _) = NoExtField +type instance XOverLabel (GhcPass _) = NoExtField +type instance XIPVar (GhcPass _) = NoExtField +type instance XOverLitE (GhcPass _) = NoExtField +type instance XLitE (GhcPass _) = NoExtField +type instance XLam (GhcPass _) = NoExtField +type instance XLamCase (GhcPass _) = NoExtField +type instance XApp (GhcPass _) = NoExtField -type instance XAppTypeE (GhcPass _) = NoExt +type instance XAppTypeE (GhcPass _) = NoExtField -type instance XOpApp GhcPs = NoExt +type instance XOpApp GhcPs = NoExtField type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = Fixity -type instance XNegApp (GhcPass _) = NoExt -type instance XPar (GhcPass _) = NoExt -type instance XSectionL (GhcPass _) = NoExt -type instance XSectionR (GhcPass _) = NoExt -type instance XExplicitTuple (GhcPass _) = NoExt +type instance XNegApp (GhcPass _) = NoExtField +type instance XPar (GhcPass _) = NoExtField +type instance XSectionL (GhcPass _) = NoExtField +type instance XSectionR (GhcPass _) = NoExtField +type instance XExplicitTuple (GhcPass _) = NoExtField -type instance XExplicitSum GhcPs = NoExt -type instance XExplicitSum GhcRn = NoExt +type instance XExplicitSum GhcPs = NoExtField +type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] -type instance XCase (GhcPass _) = NoExt -type instance XIf (GhcPass _) = NoExt +type instance XCase (GhcPass _) = NoExtField +type instance XIf (GhcPass _) = NoExtField -type instance XMultiIf GhcPs = NoExt -type instance XMultiIf GhcRn = NoExt +type instance XMultiIf GhcPs = NoExtField +type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type -type instance XLet (GhcPass _) = NoExt +type instance XLet (GhcPass _) = NoExtField -type instance XDo GhcPs = NoExt -type instance XDo GhcRn = NoExt +type instance XDo GhcPs = NoExtField +type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = NoExt -type instance XExplicitList GhcRn = NoExt +type instance XExplicitList GhcPs = NoExtField +type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -type instance XRecordCon GhcPs = NoExt -type instance XRecordCon GhcRn = NoExt +type instance XRecordCon GhcPs = NoExtField +type instance XRecordCon GhcRn = NoExtField type instance XRecordCon GhcTc = RecordConTc -type instance XRecordUpd GhcPs = NoExt -type instance XRecordUpd GhcRn = NoExt +type instance XRecordUpd GhcPs = NoExtField +type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = RecordUpdTc -type instance XExprWithTySig (GhcPass _) = NoExt +type instance XExprWithTySig (GhcPass _) = NoExtField -type instance XArithSeq GhcPs = NoExt -type instance XArithSeq GhcRn = NoExt +type instance XArithSeq GhcPs = NoExtField +type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XSCC (GhcPass _) = NoExt -type instance XCoreAnn (GhcPass _) = NoExt -type instance XBracket (GhcPass _) = NoExt +type instance XSCC (GhcPass _) = NoExtField +type instance XCoreAnn (GhcPass _) = NoExtField +type instance XBracket (GhcPass _) = NoExtField -type instance XRnBracketOut (GhcPass _) = NoExt -type instance XTcBracketOut (GhcPass _) = NoExt +type instance XRnBracketOut (GhcPass _) = NoExtField +type instance XTcBracketOut (GhcPass _) = NoExtField -type instance XSpliceE (GhcPass _) = NoExt -type instance XProc (GhcPass _) = NoExt +type instance XSpliceE (GhcPass _) = NoExtField +type instance XProc (GhcPass _) = NoExtField -type instance XStatic GhcPs = NoExt +type instance XStatic GhcPs = NoExtField type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet -type instance XTick (GhcPass _) = NoExt -type instance XBinTick (GhcPass _) = NoExt -type instance XTickPragma (GhcPass _) = NoExt -type instance XWrap (GhcPass _) = NoExt -type instance XXExpr (GhcPass _) = NoExt +type instance XTick (GhcPass _) = NoExtField +type instance XBinTick (GhcPass _) = NoExtField +type instance XTickPragma (GhcPass _) = NoExtField +type instance XWrap (GhcPass _) = NoExtField +type instance XXExpr (GhcPass _) = NoExtCon -- --------------------------------------------------------------------- @@ -757,13 +758,13 @@ | Missing (XMissing id) -- ^ The argument is missing, but this is its type | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point -type instance XPresent (GhcPass _) = NoExt +type instance XPresent (GhcPass _) = NoExtField -type instance XMissing GhcPs = NoExt -type instance XMissing GhcRn = NoExt +type instance XMissing GhcPs = NoExtField +type instance XMissing GhcRn = NoExtField type instance XMissing GhcTc = Type -type instance XXTupArg (GhcPass _) = NoExt +type instance XXTupArg (GhcPass _) = NoExtCon tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True @@ -1076,7 +1077,7 @@ = ppr_apps fun (Left arg : args) ppr_apps (HsAppType _ (L _ fun) arg) args = ppr_apps fun (Right arg : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args)) +ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) where pp (Left arg) = ppr arg -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) @@ -1173,7 +1174,7 @@ -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e) - | hsExprNeedsParens p e = L loc (HsPar NoExt le) + | hsExprNeedsParens p e = L loc (HsPar noExtField le) | otherwise = le isAtomicHsExpr :: HsExpr id -> Bool @@ -1298,24 +1299,24 @@ -- Then (HsCmdWrap wrap cmd) :: arg2 --> res | XCmd (XXCmd id) -- Note [Trees that Grow] extension point -type instance XCmdArrApp GhcPs = NoExt -type instance XCmdArrApp GhcRn = NoExt +type instance XCmdArrApp GhcPs = NoExtField +type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm (GhcPass _) = NoExt -type instance XCmdApp (GhcPass _) = NoExt -type instance XCmdLam (GhcPass _) = NoExt -type instance XCmdPar (GhcPass _) = NoExt -type instance XCmdCase (GhcPass _) = NoExt -type instance XCmdIf (GhcPass _) = NoExt -type instance XCmdLet (GhcPass _) = NoExt +type instance XCmdArrForm (GhcPass _) = NoExtField +type instance XCmdApp (GhcPass _) = NoExtField +type instance XCmdLam (GhcPass _) = NoExtField +type instance XCmdPar (GhcPass _) = NoExtField +type instance XCmdCase (GhcPass _) = NoExtField +type instance XCmdIf (GhcPass _) = NoExtField +type instance XCmdLet (GhcPass _) = NoExtField -type instance XCmdDo GhcPs = NoExt -type instance XCmdDo GhcRn = NoExt +type instance XCmdDo GhcPs = NoExtField +type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type -type instance XCmdWrap (GhcPass _) = NoExt -type instance XXCmd (GhcPass _) = NoExt +type instance XCmdWrap (GhcPass _) = NoExtField +type instance XXCmd (GhcPass _) = NoExtCon -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1341,11 +1342,11 @@ Type -- return type of the command (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] -type instance XCmdTop GhcPs = NoExt +type instance XCmdTop GhcPs = NoExtField type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc -type instance XXCmdTop (GhcPass _) = NoExt +type instance XXCmdTop (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd @@ -1491,11 +1492,11 @@ , mg_res_ty :: Type -- Type of the result, tr } deriving Data -type instance XMG GhcPs b = NoExt -type instance XMG GhcRn b = NoExt +type instance XMG GhcPs b = NoExtField +type instance XMG GhcRn b = NoExtField type instance XMG GhcTc b = MatchGroupTc -type instance XXMatchGroup (GhcPass _) b = NoExt +type instance XXMatchGroup (GhcPass _) b = NoExtCon -- | Located Match type LMatch id body = Located (Match id body) @@ -1513,8 +1514,8 @@ } | XMatch (XXMatch p body) -type instance XCMatch (GhcPass _) b = NoExt -type instance XXMatch (GhcPass _) b = NoExt +type instance XCMatch (GhcPass _) b = NoExtField +type instance XXMatch (GhcPass _) b = NoExtCon instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) => Outputable (Match idR body) where @@ -1564,7 +1565,7 @@ isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms -isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup" +isEmptyMatchGroup (XMatchGroup {}) = False -- | Is there only one RHS in this list of matches? isSingletonMatchGroup :: [LMatch id body] -> Bool @@ -1575,17 +1576,17 @@ | otherwise = False -matchGroupArity :: MatchGroup id body -> Arity +matchGroupArity :: MatchGroup (GhcPass id) body -> Arity -- Precondition: MatchGroup is non-empty -- This is called before type checking, when mg_arg_tys is not set matchGroupArity (MG { mg_alts = alts }) | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) | otherwise = panic "matchGroupArity" -matchGroupArity (XMatchGroup{}) = panic "matchGroupArity" +matchGroupArity (XMatchGroup nec) = noExtCon nec -hsLMatchPats :: LMatch id body -> [LPat id] +hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = pats })) = pats -hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats" +hsLMatchPats (L _ (XMatch nec)) = noExtCon nec -- | Guarded Right-Hand Sides -- @@ -1605,8 +1606,8 @@ } | XGRHSs (XXGRHSs p body) -type instance XCGRHSs (GhcPass _) b = NoExt -type instance XXGRHSs (GhcPass _) b = NoExt +type instance XCGRHSs (GhcPass _) b = NoExtField +type instance XXGRHSs (GhcPass _) b = NoExtCon -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) @@ -1617,8 +1618,8 @@ body -- Right hand side | XGRHS (XXGRHS p body) -type instance XCGRHS (GhcPass _) b = NoExt -type instance XXGRHS (GhcPass _) b = NoExt +type instance XCGRHS (GhcPass _) b = NoExtField +type instance XXGRHS (GhcPass _) b = NoExtCon -- We know the list must have at least one @Match@ in it. @@ -1887,35 +1888,35 @@ } -type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField -type instance XBindStmt (GhcPass _) GhcPs b = NoExt -type instance XBindStmt (GhcPass _) GhcRn b = NoExt +type instance XBindStmt (GhcPass _) GhcPs b = NoExtField +type instance XBindStmt (GhcPass _) GhcRn b = NoExtField type instance XBindStmt (GhcPass _) GhcTc b = Type -type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt -type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt +type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField type instance XApplicativeStmt (GhcPass _) GhcTc b = Type -type instance XBodyStmt (GhcPass _) GhcPs b = NoExt -type instance XBodyStmt (GhcPass _) GhcRn b = NoExt +type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField +type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField type instance XBodyStmt (GhcPass _) GhcTc b = Type -type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt +type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField -type instance XParStmt (GhcPass _) GhcPs b = NoExt -type instance XParStmt (GhcPass _) GhcRn b = NoExt +type instance XParStmt (GhcPass _) GhcPs b = NoExtField +type instance XParStmt (GhcPass _) GhcRn b = NoExtField type instance XParStmt (GhcPass _) GhcTc b = Type -type instance XTransStmt (GhcPass _) GhcPs b = NoExt -type instance XTransStmt (GhcPass _) GhcRn b = NoExt +type instance XTransStmt (GhcPass _) GhcPs b = NoExtField +type instance XTransStmt (GhcPass _) GhcRn b = NoExtField type instance XTransStmt (GhcPass _) GhcTc b = Type -type instance XRecStmt (GhcPass _) GhcPs b = NoExt -type instance XRecStmt (GhcPass _) GhcRn b = NoExt +type instance XRecStmt (GhcPass _) GhcPs b = NoExtField +type instance XRecStmt (GhcPass _) GhcRn b = NoExtField type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc -type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt +type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) @@ -1931,8 +1932,8 @@ (SyntaxExpr idR) -- The return operator | XParStmtBlock (XXParStmtBlock idL idR) -type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt -type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon -- | Applicative Argument data ApplicativeArg idL @@ -1951,9 +1952,9 @@ (LPat idL) -- (v1,...,vn) | XApplicativeArg (XXApplicativeArg idL) -type instance XApplicativeArgOne (GhcPass _) = NoExt -type instance XApplicativeArgMany (GhcPass _) = NoExt -type instance XXApplicativeArg (GhcPass _) = NoExt +type instance XApplicativeArgOne (GhcPass _) = NoExtField +type instance XApplicativeArgMany (GhcPass _) = NoExtField +type instance XXApplicativeArg (GhcPass _) = NoExtCon {- Note [The type of bind in Stmts] @@ -2184,7 +2185,7 @@ :: ExprStmt (GhcPass idL))] flattenArg (_, ApplicativeArgMany _ stmts _ _) = concatMap flattenStmt stmts - flattenArg (_, XApplicativeArg _) = panic "flattenArg" + flattenArg (_, XApplicativeArg nec) = noExtCon nec pp_debug = let @@ -2207,7 +2208,7 @@ text "<-" <+> ppr (HsDo (panic "pprStmt") DoExpr (noLoc (stmts ++ - [noLoc (LastStmt noExt (noLoc return) False noSyntaxExpr)]))) + [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)]))) pp_arg (_, XApplicativeArg x) = ppr x pprStmt (XStmtLR x) = ppr x @@ -2308,11 +2309,11 @@ DelayedSplice | XSplice (XXSplice id) -- Note [Trees that Grow] extension point -type instance XTypedSplice (GhcPass _) = NoExt -type instance XUntypedSplice (GhcPass _) = NoExt -type instance XQuasiQuote (GhcPass _) = NoExt -type instance XSpliced (GhcPass _) = NoExt -type instance XXSplice (GhcPass _) = NoExt +type instance XTypedSplice (GhcPass _) = NoExtField +type instance XUntypedSplice (GhcPass _) = NoExtField +type instance XQuasiQuote (GhcPass _) = NoExtField +type instance XSpliced (GhcPass _) = NoExtField +type instance XXSplice (GhcPass _) = NoExtCon -- | A splice can appear with various decorations wrapped around it. This data -- type captures explicitly how it was originally written, for use in the pretty @@ -2515,14 +2516,14 @@ | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] | XBracket (XXBracket p) -- Note [Trees that Grow] extension point -type instance XExpBr (GhcPass _) = NoExt -type instance XPatBr (GhcPass _) = NoExt -type instance XDecBrL (GhcPass _) = NoExt -type instance XDecBrG (GhcPass _) = NoExt -type instance XTypBr (GhcPass _) = NoExt -type instance XVarBr (GhcPass _) = NoExt -type instance XTExpBr (GhcPass _) = NoExt -type instance XXBracket (GhcPass _) = NoExt +type instance XExpBr (GhcPass _) = NoExtField +type instance XPatBr (GhcPass _) = NoExtField +type instance XDecBrL (GhcPass _) = NoExtField +type instance XDecBrG (GhcPass _) = NoExtField +type instance XTypBr (GhcPass _) = NoExtField +type instance XVarBr (GhcPass _) = NoExtField +type instance XTExpBr (GhcPass _) = NoExtField +type instance XXBracket (GhcPass _) = NoExtCon isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -53,17 +55,80 @@ -} --- | used as place holder in TTG values -data NoExt = NoExt +-- | A placeholder type for TTG extension points that are not currently +-- unused to represent any particular value. +-- +-- This should not be confused with 'NoExtCon', which are found in unused +-- extension /constructors/ and therefore should never be inhabited. In +-- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of +-- some constructor), so it must have an inhabitant to construct AST passes +-- that manipulate fields with that extension point as their type. +data NoExtField = NoExtField deriving (Data,Eq,Ord) -instance Outputable NoExt where - ppr _ = text "NoExt" +instance Outputable NoExtField where + ppr _ = text "NoExtField" -- | Used when constructing a term with an unused extension point. -noExt :: NoExt -noExt = NoExt +noExtField :: NoExtField +noExtField = NoExtField +-- | Used in TTG extension constructors that have yet to be extended with +-- anything. If an extension constructor has 'NoExtCon' as its field, it is +-- not intended to ever be constructed anywhere, and any function that consumes +-- the extension constructor can eliminate it by way of 'noExtCon'. +-- +-- This should not be confused with 'NoExtField', which are found in unused +-- extension /points/ (not /constructors/) and therefore can be inhabited. + +-- See also [NoExtCon and strict fields]. +data NoExtCon + deriving (Data,Eq,Ord) + +instance Outputable NoExtCon where + ppr = noExtCon + +-- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'. +noExtCon :: NoExtCon -> a +noExtCon x = case x of {} + +{- +Note [NoExtCon and strict fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, any unused TTG extension constructor will generally look like the +following: + + type instance XXHsDecl (GhcPass _) = NoExtCon + data HsDecl p + = ... + | XHsDecl (XXHsDecl p) + +This means that any function that wishes to consume an HsDecl will need to +have a case for XHsDecl. This might look like this: + + ex :: HsDecl GhcPs -> HsDecl GhcRn + ... + ex (XHsDecl nec) = noExtCon nec + +Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be +an unused extension constructor, after all). There is a way to achieve this +on GHC 8.8 or later: make the field of XHsDecl strict: + + data HsDecl p + = ... + | XHsDecl !(XXHsDecl p) + +If this is done, GHC's pattern-match coverage checker is clever enough to +figure out that the XHsDecl case of `ex` is unreachable, so it can simply be +omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on +how this works.) + +When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make +the strict field changes described above and delete gobs of code involving +`noExtCon`. Until then, it is necessary to use, so be aware of it when writing +code that consumes unused extension constructors. +-} + -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) @@ -1068,7 +1133,7 @@ -- -- So -- --- type instance XXHsIPBinds (GhcPass p) = NoExt +-- type instance XXHsIPBinds (GhcPass p) = NoExtCon -- -- will correctly deduce Outputable for (GhcPass p), but -- diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -108,12 +108,12 @@ -- For details on above see note [Api annotations] in ApiAnnotation -type instance XCImportDecl (GhcPass _) = NoExt -type instance XXImportDecl (GhcPass _) = NoExt +type instance XCImportDecl (GhcPass _) = NoExtField +type instance XXImportDecl (GhcPass _) = NoExtCon simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) simpleImportDecl mn = ImportDecl { - ideclExt = noExt, + ideclExt = noExtField, ideclSourceSrc = NoSourceText, ideclName = noLoc mn, ideclPkgQual = Nothing, @@ -254,15 +254,15 @@ | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc | XIE (XXIE pass) -type instance XIEVar (GhcPass _) = NoExt -type instance XIEThingAbs (GhcPass _) = NoExt -type instance XIEThingAll (GhcPass _) = NoExt -type instance XIEThingWith (GhcPass _) = NoExt -type instance XIEModuleContents (GhcPass _) = NoExt -type instance XIEGroup (GhcPass _) = NoExt -type instance XIEDoc (GhcPass _) = NoExt -type instance XIEDocNamed (GhcPass _) = NoExt -type instance XXIE (GhcPass _) = NoExt +type instance XIEVar (GhcPass _) = NoExtField +type instance XIEThingAbs (GhcPass _) = NoExtField +type instance XIEThingAll (GhcPass _) = NoExtField +type instance XIEThingWith (GhcPass _) = NoExtField +type instance XIEModuleContents (GhcPass _) = NoExtField +type instance XIEGroup (GhcPass _) = NoExtField +type instance XIEDoc (GhcPass _) = NoExtField +type instance XIEDocNamed (GhcPass _) = NoExtField +type instance XXIE (GhcPass _) = NoExtCon -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) @@ -284,14 +284,14 @@ See Note [Representing fields in AvailInfo] in Avail for more details. -} -ieName :: IE pass -> IdP pass +ieName :: IE (GhcPass p) -> IdP (GhcPass p) ieName (IEVar _ (L _ n)) = ieWrappedName n ieName (IEThingAbs _ (L _ n)) = ieWrappedName n ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n ieName (IEThingAll _ (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" -ieNames :: IE pass -> [IdP pass] +ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] @@ -301,7 +301,7 @@ ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] -ieNames (XIE {}) = panic "ieNames" +ieNames (XIE nec) = noExtCon nec ieWrappedName :: IEWrappedName name -> name ieWrappedName (IEName (L _ n)) = n diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs --- a/compiler/hsSyn/HsInstances.hs +++ b/compiler/hsSyn/HsInstances.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -O0 #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -82,16 +82,16 @@ type instance XHsCharPrim (GhcPass _) = SourceText type instance XHsString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText -type instance XHsInt (GhcPass _) = NoExt +type instance XHsInt (GhcPass _) = NoExtField type instance XHsIntPrim (GhcPass _) = SourceText type instance XHsWordPrim (GhcPass _) = SourceText type instance XHsInt64Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText type instance XHsInteger (GhcPass _) = SourceText -type instance XHsRat (GhcPass _) = NoExt -type instance XHsFloatPrim (GhcPass _) = NoExt -type instance XHsDoublePrim (GhcPass _) = NoExt -type instance XXLit (GhcPass _) = NoExt +type instance XHsRat (GhcPass _) = NoExtField +type instance XHsFloatPrim (GhcPass _) = NoExtField +type instance XHsDoublePrim (GhcPass _) = NoExtField +type instance XXLit (GhcPass _) = NoExtCon instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -125,11 +125,11 @@ ol_type :: Type } deriving Data -type instance XOverLit GhcPs = NoExt +type instance XOverLit GhcPs = NoExtField type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] type instance XOverLit GhcTc = OverLitTc -type instance XXOverLit (GhcPass _) = NoExt +type instance XXOverLit (GhcPass _) = NoExtCon -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -147,7 +147,7 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty -overLitType XOverLit{} = panic "overLitType" +overLitType (XOverLit nec) = noExtCon nec -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -281,51 +281,51 @@ Type -- The type of the elements (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax -type instance XWildPat GhcPs = NoExt -type instance XWildPat GhcRn = NoExt +type instance XWildPat GhcPs = NoExtField +type instance XWildPat GhcRn = NoExtField type instance XWildPat GhcTc = Type -type instance XVarPat (GhcPass _) = NoExt -type instance XLazyPat (GhcPass _) = NoExt -type instance XAsPat (GhcPass _) = NoExt -type instance XParPat (GhcPass _) = NoExt -type instance XBangPat (GhcPass _) = NoExt +type instance XVarPat (GhcPass _) = NoExtField +type instance XLazyPat (GhcPass _) = NoExtField +type instance XAsPat (GhcPass _) = NoExtField +type instance XParPat (GhcPass _) = NoExtField +type instance XBangPat (GhcPass _) = NoExtField -- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap -- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for -- `SyntaxExpr` -type instance XListPat GhcPs = NoExt +type instance XListPat GhcPs = NoExtField type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) type instance XListPat GhcTc = ListPatTc -type instance XTuplePat GhcPs = NoExt -type instance XTuplePat GhcRn = NoExt +type instance XTuplePat GhcPs = NoExtField +type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = NoExt -type instance XSumPat GhcRn = NoExt +type instance XSumPat GhcPs = NoExtField +type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XViewPat GhcPs = NoExt -type instance XViewPat GhcRn = NoExt +type instance XViewPat GhcPs = NoExtField +type instance XViewPat GhcRn = NoExtField type instance XViewPat GhcTc = Type -type instance XSplicePat (GhcPass _) = NoExt -type instance XLitPat (GhcPass _) = NoExt +type instance XSplicePat (GhcPass _) = NoExtField +type instance XLitPat (GhcPass _) = NoExtField -type instance XNPat GhcPs = NoExt -type instance XNPat GhcRn = NoExt +type instance XNPat GhcPs = NoExtField +type instance XNPat GhcRn = NoExtField type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = NoExt -type instance XNPlusKPat GhcRn = NoExt +type instance XNPlusKPat GhcPs = NoExtField +type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = NoExt -type instance XSigPat GhcRn = NoExt +type instance XSigPat GhcPs = NoExtField +type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type -type instance XCoPat (GhcPass _) = NoExt +type instance XCoPat (GhcPass _) = NoExtField type instance XXPat (GhcPass p) = Located (Pat (GhcPass p)) @@ -460,11 +460,11 @@ -- -- The parsed HsRecUpdField corresponding to the record update will have: -- --- hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName +-- hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName -- -- After the renamer, this will become: -- --- hsRecFieldLbl = Ambiguous "x" NoExt :: AmbiguousFieldOcc Name +-- hsRecFieldLbl = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name -- -- (note that the Unambiguous constructor is not type-correct here). -- The typechecker will determine the particular selector: @@ -584,7 +584,7 @@ pprConArgs :: (OutputableBndrId (GhcPass p)) => HsConPatDetails (GhcPass p) -> SDoc -pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats) +pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats @@ -630,7 +630,7 @@ mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat NoExt (HsCharPrim src c)] [] + [noLoc $ LitPat noExtField (HsCharPrim src c)] [] {- ************************************************************************ @@ -811,7 +811,7 @@ -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) parenthesizePat p lpat@(dL->L loc pat) - | patNeedsParens p pat = cL loc (ParPat NoExt lpat) + | patNeedsParens p pat = cL loc (ParPat noExtField lpat) | otherwise = lpat {- diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -70,6 +70,8 @@ hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext ) where +#include "HsVersions.h" + import GhcPrelude import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) @@ -90,7 +92,7 @@ import Outputable import FastString import Maybes( isJust ) -import Util ( count ) +import Util ( count, debugIsOn ) import Data.Data hiding ( Fixity, Prefix, Infix ) @@ -334,14 +336,14 @@ -- For example, in data T (a :: k1 -> k2) = ... -- the 'a' is explicit while 'k1', 'k2' are implicit -type instance XHsQTvs GhcPs = NoExt +type instance XHsQTvs GhcPs = NoExtField type instance XHsQTvs GhcRn = HsQTvsRn type instance XHsQTvs GhcTc = HsQTvsRn -type instance XXLHsQTyVars (GhcPass _) = NoExt +type instance XXLHsQTyVars (GhcPass _) = NoExtCon mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs -mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs } +mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] hsQTvExplicit = hsq_explicit @@ -372,11 +374,11 @@ } | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) -type instance XHsIB GhcPs _ = NoExt +type instance XHsIB GhcPs _ = NoExtField type instance XHsIB GhcRn _ = [Name] type instance XHsIB GhcTc _ = [Name] -type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt +type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon -- | Haskell Wildcard Binders data HsWildCardBndrs pass thing @@ -394,11 +396,11 @@ } | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) -type instance XHsWC GhcPs b = NoExt +type instance XHsWC GhcPs b = NoExtField type instance XHsWC GhcRn b = [Name] type instance XHsWC GhcTc b = [Name] -type instance XXHsWildCardBndrs (GhcPass _) b = NoExt +type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon -- | Located Haskell Signature Type type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only @@ -411,11 +413,11 @@ -- See Note [Representing type signatures] -hsImplicitBody :: HsImplicitBndrs pass thing -> thing +hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing hsImplicitBody (HsIB { hsib_body = body }) = body -hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody" +hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec -hsSigType :: LHsSigType pass -> LHsType pass +hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) hsSigType = hsImplicitBody hsSigWcType :: LHsSigWcType pass -> LHsType pass @@ -446,12 +448,12 @@ -} mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing -mkHsImplicitBndrs x = HsIB { hsib_ext = noExt +mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField , hsib_body = x } mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_ext = noExt } + , hswc_ext = noExtField } -- Add empty binders. This is a bit suspicious; what if -- the wrapped thing had free type variables? @@ -502,15 +504,15 @@ | XTyVarBndr (XXTyVarBndr pass) -type instance XUserTyVar (GhcPass _) = NoExt -type instance XKindedTyVar (GhcPass _) = NoExt -type instance XXTyVarBndr (GhcPass _) = NoExt +type instance XUserTyVar (GhcPass _) = NoExtField +type instance XKindedTyVar (GhcPass _) = NoExtField +type instance XXTyVarBndr (GhcPass _) = NoExtCon -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True -isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar" +isHsKindedTyVar (XTyVarBndr {}) = False -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars pass -> Bool @@ -704,41 +706,41 @@ instance Outputable NewHsTypeX where ppr (NHsCoreTy ty) = ppr ty -type instance XForAllTy (GhcPass _) = NoExt -type instance XQualTy (GhcPass _) = NoExt -type instance XTyVar (GhcPass _) = NoExt -type instance XAppTy (GhcPass _) = NoExt -type instance XFunTy (GhcPass _) = NoExt -type instance XListTy (GhcPass _) = NoExt -type instance XTupleTy (GhcPass _) = NoExt -type instance XSumTy (GhcPass _) = NoExt -type instance XOpTy (GhcPass _) = NoExt -type instance XParTy (GhcPass _) = NoExt -type instance XIParamTy (GhcPass _) = NoExt -type instance XStarTy (GhcPass _) = NoExt -type instance XKindSig (GhcPass _) = NoExt +type instance XForAllTy (GhcPass _) = NoExtField +type instance XQualTy (GhcPass _) = NoExtField +type instance XTyVar (GhcPass _) = NoExtField +type instance XAppTy (GhcPass _) = NoExtField +type instance XFunTy (GhcPass _) = NoExtField +type instance XListTy (GhcPass _) = NoExtField +type instance XTupleTy (GhcPass _) = NoExtField +type instance XSumTy (GhcPass _) = NoExtField +type instance XOpTy (GhcPass _) = NoExtField +type instance XParTy (GhcPass _) = NoExtField +type instance XIParamTy (GhcPass _) = NoExtField +type instance XStarTy (GhcPass _) = NoExtField +type instance XKindSig (GhcPass _) = NoExtField type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives -type instance XSpliceTy GhcPs = NoExt -type instance XSpliceTy GhcRn = NoExt +type instance XSpliceTy GhcPs = NoExtField +type instance XSpliceTy GhcRn = NoExtField type instance XSpliceTy GhcTc = Kind -type instance XDocTy (GhcPass _) = NoExt -type instance XBangTy (GhcPass _) = NoExt -type instance XRecTy (GhcPass _) = NoExt +type instance XDocTy (GhcPass _) = NoExtField +type instance XBangTy (GhcPass _) = NoExtField +type instance XRecTy (GhcPass _) = NoExtField -type instance XExplicitListTy GhcPs = NoExt -type instance XExplicitListTy GhcRn = NoExt +type instance XExplicitListTy GhcPs = NoExtField +type instance XExplicitListTy GhcRn = NoExtField type instance XExplicitListTy GhcTc = Kind -type instance XExplicitTupleTy GhcPs = NoExt -type instance XExplicitTupleTy GhcRn = NoExt +type instance XExplicitTupleTy GhcPs = NoExtField +type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] -type instance XTyLit (GhcPass _) = NoExt +type instance XTyLit (GhcPass _) = NoExtField -type instance XWildCardTy (GhcPass _) = NoExt +type instance XWildCardTy (GhcPass _) = NoExtField type instance XXType (GhcPass _) = NewHsTypeX @@ -890,8 +892,8 @@ -- For details on above see note [Api annotations] in ApiAnnotation | XConDeclField (XXConDeclField pass) -type instance XConDeclField (GhcPass _) = NoExt -type instance XXConDeclField (GhcPass _) = NoExt +type instance XConDeclField (GhcPass _) = NoExtField +type instance XXConDeclField (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDeclField p) where @@ -949,7 +951,6 @@ hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] -- Get the lexically-scoped type variables of a HsSigType -- - the explicitly-given forall'd type variables --- - the implicitly-bound kind variables -- - the named wildcars; see Note [Scoping of named wildcards] -- because they scope in the same way hsWcScopedTvs sig_ty @@ -957,21 +958,23 @@ , HsIB { hsib_ext = vars , hsib_body = sig_ty2 } <- sig_ty1 = case sig_ty2 of - L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ - hsLTyVarNames tvs - -- include kind variables only if the type is headed by forall - -- (this is consistent with GHC 7 behaviour) + L _ (HsForAllTy { hst_fvf = vis_flag + , hst_bndrs = tvs }) -> + ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] + vars ++ nwcs ++ hsLTyVarNames tvs _ -> nwcs -hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs" -hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs" +hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec +hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec hsScopedTvs :: LHsSigType GhcRn -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty | HsIB { hsib_ext = vars , hsib_body = sig_ty2 } <- sig_ty - , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 - = vars ++ hsLTyVarNames tvs + , L _ (HsForAllTy { hst_fvf = vis_flag + , hst_bndrs = tvs }) <- sig_ty2 + = ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] + vars ++ hsLTyVarNames tvs | otherwise = [] @@ -988,19 +991,61 @@ I don't know if this is a good idea, but there it is. -} +{- Note [hsScopedTvs vis_flag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-XScopedTypeVariables can be defined in terms of a desugaring to +-XTypeAbstractions (GHC Proposal #50): + + fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) + fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) + +That is, for every type variable of the leading 'forall' in the type signature, +we add an invisible binder at term level. + +This model does not extend to visible forall, as discussed here: + +* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 +* https://github.com/ghc-proposals/ghc-proposals/pull/238 + +The conclusion of these discussions can be summarized as follows: + + > Assuming support for visible 'forall' in terms, consider this example: + > + > vfn :: forall x y -> tau(x,y) + > vfn = \a b -> ... + > + > The user has written their own binders 'a' and 'b' to stand for 'x' and + > 'y', and we definitely should not desugar this into: + > + > vfn :: forall x y -> tau(x,y) + > vfn x y = \a b -> ... -- bad! + +At the moment, GHC does not support visible 'forall' in terms, so we simply cement +our assumptions with an assert: + + hsScopedTvs (HsForAllTy { hst_fvf = vis_flag, ... }) = + ASSERT( vis_flag == ForallInvis ) + ... + +In the future, this assert can be safely turned into a pattern match to support +visible forall in terms: + + hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ... +-} + --------------------- -hsTyVarName :: HsTyVarBndr pass -> IdP pass +hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) hsTyVarName (UserTyVar _ (L _ n)) = n hsTyVarName (KindedTyVar _ (L _ n) _) = n -hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName" +hsTyVarName (XTyVarBndr nec) = noExtCon nec -hsLTyVarName :: LHsTyVarBndr pass -> IdP pass +hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p) hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: [LHsTyVarBndr pass] -> [IdP pass] +hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = map hsLTyVarName -hsExplicitLTyVarNames :: LHsQTyVars pass -> [IdP pass] +hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) @@ -1009,28 +1054,28 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs , hsq_explicit = tvs }) = kvs ++ hsLTyVarNames tvs -hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames" +hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec -hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) +hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) hsLTyVarLocName = onHasSrcSpan hsTyVarName -hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] +hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) hsLTyVarBndrToType = onHasSrcSpan cvt - where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n + where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n cvt (KindedTyVar _ (L name_loc n) kind) - = HsKindSig noExt - (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind - cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType" + = HsKindSig noExtField + (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind + cvt (XTyVarBndr nec) = noExtCon nec -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs -hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes" +hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec --------------------- ignoreParens :: LHsType pass -> LHsType pass @@ -1050,15 +1095,15 @@ -} mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy noExt +mkAnonWildCardTy = HsWildCardTy noExtField mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2 +mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2 - = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeHsType appPrec t2)) + = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) @@ -1270,9 +1315,9 @@ = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope -splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy" +splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec -getLHsInstDeclHead :: LHsSigType pass -> LHsType pass +getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) = body_ty @@ -1311,17 +1356,17 @@ deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) -type instance XCFieldOcc GhcPs = NoExt +type instance XCFieldOcc GhcPs = NoExtField type instance XCFieldOcc GhcRn = Name type instance XCFieldOcc GhcTc = Id -type instance XXFieldOcc (GhcPass _) = NoExt +type instance XXFieldOcc (GhcPass _) = NoExtCon instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc noExt rdr +mkFieldOcc rdr = FieldOcc noExtField rdr -- | Ambiguous Field Occurrence @@ -1341,15 +1386,15 @@ | Ambiguous (XAmbiguous pass) (Located RdrName) | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) -type instance XUnambiguous GhcPs = NoExt +type instance XUnambiguous GhcPs = NoExtField type instance XUnambiguous GhcRn = Name type instance XUnambiguous GhcTc = Id -type instance XAmbiguous GhcPs = NoExt -type instance XAmbiguous GhcRn = NoExt +type instance XAmbiguous GhcPs = NoExtField +type instance XAmbiguous GhcRn = NoExtField type instance XAmbiguous GhcTc = Id -type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt +type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where ppr = ppr . rdrNameAmbiguousFieldOcc @@ -1359,28 +1404,28 @@ pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr +mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "rdrNameAmbiguousFieldOcc" +rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec) + = noExtCon nec selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id selectorAmbiguousFieldOcc (Unambiguous sel _) = sel selectorAmbiguousFieldOcc (Ambiguous sel _) = sel -selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "selectorAmbiguousFieldOcc" +selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec) + = noExtCon nec unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc" +unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr -ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" +ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec {- ************************************************************************ @@ -1664,7 +1709,7 @@ -- returns @ty@. parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeHsType p lty@(L loc ty) - | hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty) + | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) | otherwise = lty -- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -106,7 +106,7 @@ import RdrName import Var import TyCoRep -import Type ( appTyArgFlags, splitAppTys, tyConArgFlags ) +import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) import TysWiredIn ( unitTy ) import TcType import DataCon @@ -140,14 +140,14 @@ -} mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = cL (getLoc e) (HsPar noExt e) +mkHsPar e = cL (getLoc e) (HsPar noExtField e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs = cL loc $ - Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats + Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where loc = case pats of @@ -157,16 +157,16 @@ unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) unguardedGRHSs rhs@(dL->L loc _) - = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds) + = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)] +unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] -mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt) +mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] -> MatchGroup name (Located (body name)) -mkMatchGroup origin matches = MG { mg_ext = noExt +mkMatchGroup origin matches = MG { mg_ext = noExtField , mg_alts = mkLocatedList matches , mg_origin = origin } @@ -175,11 +175,11 @@ mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2) +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn) => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id) -mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct) +mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) where t_body = hswc_body t paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } @@ -187,9 +187,9 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExt) => +mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches)) +mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats' body] @@ -208,7 +208,7 @@ nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) nlHsTyApp fun_id tys - = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id))) + = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) @@ -219,16 +219,16 @@ -- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' mkLHsPar le@(dL->L loc e) - | hsExprNeedsParens appPrec e = cL loc (HsPar noExt le) + | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) mkParPat lp@(dL->L loc p) - | patNeedsParens appPrec p = cL loc (ParPat noExt lp) + | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -nlParPat p = noLoc (ParPat noExt p) +nlParPat p = noLoc (ParPat noExtField p) ------------------------------- -- These are the bits of syntax that contain rebindable names @@ -250,7 +250,7 @@ mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) - (Located (bodyR (GhcPass idR))) ~ NoExt) + (Located (bodyR (GhcPass idR))) ~ NoExtField) => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) @@ -263,26 +263,26 @@ -> StmtLR (GhcPass idL) GhcPs bodyR -mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr -mkHsFractional f = OverLit noExt (HsFractional f) noExpr -mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr +mkHsIntegral i = OverLit noExtField (HsIntegral i) noExpr +mkHsFractional f = OverLit noExtField (HsFractional f) noExpr +mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr -mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) +mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = cL (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) -mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b +mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -> HsCmd (GhcPass p) -mkHsCmdIf c a b = HsCmdIf noExt (Just noSyntaxExpr) c a b +mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b -mkNPat lit neg = NPat noExt lit neg noSyntaxExpr +mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr mkNPlusKPat id lit - = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr + = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) @@ -295,7 +295,7 @@ -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt = TransStmt { trS_ext = noExt +emptyTransStmt = TransStmt { trS_ext = noExtField , trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noExpr @@ -306,11 +306,11 @@ mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt body = LastStmt noExt body False noSyntaxExpr +mkLastStmt body = LastStmt noExtField body False noSyntaxExpr mkBodyStmt body - = BodyStmt noExt body noSyntaxExpr noSyntaxExpr + = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr mkBindStmt pat body - = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr + = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr -- don't use placeHolderTypeTc above, because that panics during zonking @@ -332,8 +332,8 @@ , recS_rec_rets = [] , recS_ret_ty = unitTy } -emptyRecStmt = emptyRecStmt' noExt -emptyRecStmtName = emptyRecStmt' noExt +emptyRecStmt = emptyRecStmt' noExtField +emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -342,20 +342,20 @@ --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2 +mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e +mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkTypedSplice hasParen e = HsTypedSplice noExt hasParen unqualSplice e +mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote - = HsQuasiQuote noExt unqualSplice quoter span quote + = HsQuasiQuote noExtField unqualSplice quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) @@ -372,11 +372,11 @@ userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] -> [LHsTyVarBndr (GhcPass p)] -- Caller sets location -userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ] +userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExtField v) | v <- bndrs ] userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v)) +userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExtField (cL loc v)) | v <- bndrs ] @@ -389,26 +389,26 @@ -} nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) -nlHsVar n = noLoc (HsVar noExt (noLoc n)) +nlHsVar n = noLoc (HsVar noExtField (noLoc n)) -- NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr GhcTc -nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con)) +nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) -nlHsLit n = noLoc (HsLit noExt n) +nlHsLit n = noLoc (HsLit noExtField n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n))) +nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) -nlVarPat n = noLoc (VarPat noExt (noLoc n)) +nlVarPat n = noLoc (VarPat noExtField (noLoc n)) nlLitPat :: HsLit GhcPs -> LPat GhcPs -nlLitPat l = noLoc (LitPat noExt l) +nlLitPat l = noLoc (LitPat noExtField l) nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x)) +nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) @@ -427,10 +427,10 @@ nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) -nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f)) - (map ((HsVar noExt) . noLoc) xs)) +nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f)) + (map ((HsVar noExtField) . noLoc) xs)) where - mk f a = HsApp noExt (noLoc f) (noLoc a) + mk f a = HsApp noExtField (noLoc f) (noLoc a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) @@ -460,10 +460,10 @@ nlWildPat))) nlWildPat :: LPat GhcPs -nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking +nlWildPat = noLoc (WildPat noExtField ) -- Pre-typechecking nlWildPatName :: LPat GhcRn -nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking +nlWildPatName = noLoc (WildPat noExtField ) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs @@ -480,27 +480,27 @@ -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar noExt e) +nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar noExtField e) -- Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false) +nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false) nlHsCase expr matches - = noLoc (HsCase noExt expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList noExt Nothing exprs) + = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) +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) nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t)) -nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) b) -nlHsParTy t = noLoc (HsParTy noExt t) +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) +nlHsParTy t = noLoc (HsParTy noExtField t) nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys @@ -519,21 +519,21 @@ -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e mkLHsTupleExpr es - = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed + = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs -nlTuplePat pats box = noLoc (TuplePat noExt pats box) +nlTuplePat pats box = noLoc (TuplePat noExtField pats box) missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing noExt +missingTupArg = Missing noExtField mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn -mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed +mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed +mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -637,7 +637,7 @@ = map fiddle sigs where fiddle (dL->L loc (TypeSig _ nms ty)) - = cL loc (ClassOpSig noExt False nms (dropWildCards ty)) + = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) fiddle sig = sig typeToLHsType :: Type -> LHsType GhcPs @@ -655,25 +655,25 @@ VisArg -> nlHsFunTy (go arg) (go res) InvisArg | (theta, tau) <- tcSplitPhiTy ty -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) - , hst_xqual = noExt + , hst_xqual = noExtField , hst_body = go tau }) go ty@(ForAllTy (Bndr _ argf) _) | (tvs, tau) <- tcSplitForAllTysSameVis argf ty = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf , hst_bndrs = map go_tv tvs - , hst_xforall = noExt + , hst_xforall = noExtField , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (LitTy (NumTyLit n)) - = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n) + = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n) go (LitTy (StrTyLit s)) - = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s) + = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s) go ty@(TyConApp tc args) | tyConAppNeedsKindSig True tc (length args) -- We must produce an explicit kind signature here to make certain -- programs kind-check. See Note [Kind signatures in typeToLHsType]. - = nlHsParTy $ noLoc $ HsKindSig NoExt ty' (go (tcTypeKind ty)) + = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty)) | otherwise = ty' where ty' :: LHsType GhcPs @@ -703,7 +703,7 @@ head (zip args arg_flags) go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv)) + go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv)) (go (tyVarKind tv)) {- @@ -762,7 +762,7 @@ mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap noExt co_fn e +mkHsWrap co_fn e = HsWrap noExtField co_fn e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) @@ -777,18 +777,18 @@ mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap noExt w cmd + | otherwise = HsCmdWrap noExtField w cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat noExt co_fn p ty + | otherwise = CoPat noExtField co_fn p ty mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExt (mkWpCastN co) pat ty + | otherwise = CoPat noExtField (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -808,7 +808,7 @@ mkFunBind fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup Generated ms , fun_co_fn = idHsWrapper - , fun_ext = noExt + , fun_ext = noExtField , fun_tick = [] } mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] @@ -826,14 +826,14 @@ mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) mkVarBind var rhs = cL (getLoc rhs) $ - VarBind { var_ext = noExt, + VarBind { var_ext = noExtField, var_id = var, var_rhs = rhs, var_inline = False } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs -mkPatSynBind name details lpat dir = PatSynBind noExt psb +mkPatSynBind name details lpat dir = PatSynBind noExtField psb where - psb = PSB{ psb_ext = noExt + psb = PSB{ psb_ext = noExtField , psb_id = name , psb_args = details , psb_def = lpat @@ -867,13 +867,13 @@ -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr lbinds - = noLoc (Match { m_ext = noExt + = noLoc (Match { m_ext = noExtField , m_ctxt = ctxt , m_pats = map paren pats - , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds }) + , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) where paren lp@(dL->L l p) - | patNeedsParens appPrec p = cL l (ParPat noExt lp) + | patNeedsParens appPrec p = cL l (ParPat noExtField lp) | otherwise = lp {- @@ -1054,7 +1054,7 @@ collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat collectArgBinders _ = [] -collectStmtBinders XStmtLR{} = panic "collectStmtBinders" +collectStmtBinders (XStmtLR nec) = noExtCon nec ----------------- Patterns -------------------------- @@ -1130,7 +1130,7 @@ hs_fords = foreign_decls }) = collectHsValBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls -hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders" +hsGroupBinders (XHsGroup nec) = noExtCon nec hsTyClForeignBinders :: [TyClGroup GhcRn] -> [LForeignDecl GhcRn] @@ -1148,8 +1148,8 @@ getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl pass) - -> ([Located (IdP pass)], [LFieldOcc pass]) +hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second @@ -1162,8 +1162,8 @@ hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl { fdLName = (dL->L _ name) } })) = ([cL loc name], []) -hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ })) - = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) + = noExtCon nec hsLTyClDeclBinders (dL->L loc (SynDecl { tcdLName = (dL->L _ name) })) = ([cL loc name], []) @@ -1181,7 +1181,7 @@ hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) , tcdDataDefn = defn })) = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" -- due to #15884 @@ -1224,48 +1224,50 @@ hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {}))) - = panic "hsLInstDeclBinders" -hsLInstDeclBinders (dL->L _ (XInstDecl _)) - = panic "hsLInstDeclBinders" +hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) + = noExtCon nec +hsLInstDeclBinders (dL->L _ (XInstDecl nec)) + = noExtCon nec hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" -- due to #15884 ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl pass - -> ([Located (IdP pass)], [LFieldOcc pass]) +hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders hsDataFamInstBinders (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = XFamEqn _}}) - = panic "hsDataFamInstBinders" -hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) - = panic "hsDataFamInstBinders" + { dfid_eqn = HsIB { hsib_body = XFamEqn nec}}) + = noExtCon nec +hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) +hsDataDefnBinders :: HsDataDefn (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] -hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" +hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec ------------------- -type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] +type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] -- Filters out ones that have already been seen -hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) +hsConDeclsBinders :: [LConDecl (GhcPass p)] + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful hsConDeclsBinders cons = go id cons where - go :: Seen pass -> [LConDecl pass] - -> ([Located (IdP pass)], [LFieldOcc pass]) + go :: Seen p -> [LConDecl (GhcPass p)] + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) go _ [] = ([], []) go remSeen (r:rs) -- Don't re-mangle the location of field names, because we don't @@ -1286,10 +1288,10 @@ (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs - XConDecl _ -> panic "hsConDeclsBinders" + XConDecl nec -> noExtCon nec - get_flds :: Seen pass -> HsConDeclDetails pass - -> (Seen pass, [LFieldOcc pass]) + get_flds :: Seen p -> HsConDeclDetails (GhcPass p) + -> (Seen p, [LFieldOcc (GhcPass p)]) get_flds remSeen (RecCon flds) = (remSeen', fld_names) where @@ -1355,7 +1357,7 @@ hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts - do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits" + do_arg (_, XApplicativeArg nec) = noExtCon nec hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = [] hs_stmt (LastStmt {}) = [] @@ -1363,7 +1365,7 @@ , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - hs_stmt (XStmtLR {}) = panic "lStmtsImplicits" + hs_stmt (XStmtLR nec) = noExtCon nec hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds {}) = [] diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -1075,7 +1075,7 @@ pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs = sdocWithDynFlags $ \dflags -> - -- See Note [When to print foralls] + -- See Note [When to print foralls] in this module. ppWhen (any tv_has_kind_var tvs || any tv_is_required tvs || gopt Opt_PrintExplicitForalls dflags) $ diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -68,6 +68,7 @@ import VarEnv import VarSet import TyCoRep +import TyCoTidy ( tidyCo ) import Demand ( isTopSig ) import Data.Maybe ( catMaybes ) diff --git a/compiler/iface/ToIface.hs-boot b/compiler/iface/ToIface.hs-boot --- a/compiler/iface/ToIface.hs-boot +++ b/compiler/iface/ToIface.hs-boot @@ -1,6 +1,6 @@ module ToIface where -import {-# SOURCE #-} TyCoRep +import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion ) import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) import Var ( TyCoVarBinder ) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -O0 #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} @@ -65,6 +66,7 @@ shouldUseHexWordLiterals, positionIndependent, optimisationFlags, + setFlagsFromEnvFile, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, @@ -150,7 +152,7 @@ settings, programName, projectVersion, ghcUsagePath, ghciUsagePath, topDir, tmpDir, - versionedAppDir, + versionedAppDir, versionedFilePath, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T, pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, @@ -178,7 +180,6 @@ updOptLevel, setTmpDir, setUnitId, - interpretPackageEnv, canonicalizeHomeModule, canonicalizeModuleIfHome, @@ -219,7 +220,6 @@ -- * SSE and AVX isSseEnabled, isSse2Enabled, - isSse4_1Enabled, isSse4_2Enabled, isBmiEnabled, isBmi2Enabled, @@ -250,6 +250,7 @@ import GhcPrelude import GHC.Platform +import GHC.UniqueSubdir (uniqueSubdir) import PlatformConstants import Module import PackageConfig @@ -295,7 +296,6 @@ import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader import Control.Monad.Trans.Except -import Control.Exception (throwIO) import Data.Ord import Data.Bits @@ -309,7 +309,7 @@ import Data.Word import System.FilePath import System.Directory -import System.Environment (getEnv, lookupEnv) +import System.Environment (lookupEnv) import System.IO import System.IO.Error import Text.ParserCombinators.ReadP hiding (char) @@ -408,10 +408,13 @@ = Opt_D_dump_cmm | Opt_D_dump_cmm_from_stg | Opt_D_dump_cmm_raw - | Opt_D_dump_cmm_verbose + | Opt_D_dump_cmm_verbose_by_proc -- All of the cmm subflags (there are a lot!) automatically - -- enabled if you run -ddump-cmm-verbose + -- enabled if you run -ddump-cmm-verbose-by-proc -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_verbose + -- same as -ddump-cmm-verbose-by-proc but writes each stage + -- to a separate file (if used with -ddump-to-file) | Opt_D_dump_cmm_cfg | Opt_D_dump_cmm_cbe | Opt_D_dump_cmm_switch @@ -1499,15 +1502,8 @@ appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) return $ appdir versionedFilePath dflags --- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when --- constructing platform-version-dependent files that need to co-exist. --- versionedFilePath :: DynFlags -> FilePath -versionedFilePath dflags = TARGET_ARCH - ++ '-':TARGET_OS - ++ '-':projectVersion dflags - -- NB: This functionality is reimplemented in Cabal, so if you - -- change it, be sure to update Cabal. +versionedFilePath dflags = uniqueSubdir $ targetPlatform dflags -- | The target code type of the compilation (if any). -- @@ -3026,7 +3022,7 @@ , make_ord_flag defGhcFlag "rdynamic" $ noArg $ #if defined(linux_HOST_OS) addOptl "-rdynamic" -#elif defined (mingw32_HOST_OS) +#elif defined(mingw32_HOST_OS) addOptl "-Wl,--export-all-symbols" #else -- ignored for compat w/ gcc: @@ -3310,6 +3306,8 @@ (setDumpFlag Opt_D_dump_cmm_raw) , make_ord_flag defGhcFlag "ddump-cmm-verbose" (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" + (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) , make_ord_flag defGhcFlag "ddump-cmm-cfg" (setDumpFlag Opt_D_dump_cmm_cfg) , make_ord_flag defGhcFlag "ddump-cmm-cbe" @@ -5272,170 +5270,6 @@ then canonicalizeHomeModule dflags (moduleName mod) else mod - --- ----------------------------------------------------------------------------- --- | Find the package environment (if one exists) --- --- We interpret the package environment as a set of package flags; to be --- specific, if we find a package environment file like --- --- > clear-package-db --- > global-package-db --- > package-db blah/package.conf.d --- > package-id id1 --- > package-id id2 --- --- we interpret this as --- --- > [ -hide-all-packages --- > , -clear-package-db --- > , -global-package-db --- > , -package-db blah/package.conf.d --- > , -package-id id1 --- > , -package-id id2 --- > ] --- --- There's also an older syntax alias for package-id, which is just an --- unadorned package id --- --- > id1 --- > id2 --- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do - mPkgEnv <- runMaybeT $ msum $ [ - getCmdLineArg >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , cmdLineError env - ] - , getEnvVar >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , envError env - ] - , notIfHideAllPackages >> msum [ - findLocalEnvFile >>= probeEnvFile - , probeEnvName defaultEnvName - ] - ] - case mPkgEnv of - Nothing -> - -- No environment found. Leave DynFlags unchanged. - return dflags - Just "-" -> do - -- Explicitly disabled environment file. Leave DynFlags unchanged. - return dflags - Just envfile -> do - content <- readFile envfile - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (text ("Loaded package environment from " ++ envfile)) - let setFlags :: DynP () - setFlags = do - setGeneralFlag Opt_HideAllPackages - parseEnvFile envfile content - - (_, dflags') = runCmdLine (runEwM setFlags) dflags - - return dflags' - where - -- Loading environments (by name or by location) - - namedEnvPath :: String -> MaybeT IO FilePath - namedEnvPath name = do - appdir <- versionedAppDir dflags - return $ appdir "environments" name - - probeEnvName :: String -> MaybeT IO FilePath - probeEnvName name = probeEnvFile =<< namedEnvPath name - - probeEnvFile :: FilePath -> MaybeT IO FilePath - probeEnvFile path = do - guard =<< liftMaybeT (doesFileExist path) - return path - - probeNullEnv :: FilePath -> MaybeT IO FilePath - probeNullEnv "-" = return "-" - probeNullEnv _ = mzero - - parseEnvFile :: FilePath -> String -> DynP () - parseEnvFile envfile = mapM_ parseEntry . lines - where - parseEntry str = case words str of - ("package-db": _) -> addPkgConfRef (PkgConfFile (envdir db)) - -- relative package dbs are interpreted relative to the env file - where envdir = takeDirectory envfile - db = drop 11 str - ["clear-package-db"] -> clearPkgConf - ["global-package-db"] -> addPkgConfRef GlobalPkgConf - ["user-package-db"] -> addPkgConfRef UserPkgConf - ["package-id", pkgid] -> exposePackageId pkgid - (('-':'-':_):_) -> return () -- comments - -- and the original syntax introduced in 7.10: - [pkgid] -> exposePackageId pkgid - [] -> return () - _ -> throwGhcException $ CmdLineError $ - "Can't parse environment file entry: " - ++ envfile ++ ": " ++ str - - -- Various ways to define which environment to use - - getCmdLineArg :: MaybeT IO String - getCmdLineArg = MaybeT $ return $ packageEnv dflags - - getEnvVar :: MaybeT IO String - getEnvVar = do - mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" - case mvar of - Right var -> return var - Left err -> if isDoesNotExistError err then mzero - else liftMaybeT $ throwIO err - - notIfHideAllPackages :: MaybeT IO () - notIfHideAllPackages = - guard (not (gopt Opt_HideAllPackages dflags)) - - defaultEnvName :: String - defaultEnvName = "default" - - -- e.g. .ghc.environment.x86_64-linux-7.6.3 - localEnvFileName :: FilePath - localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags - - -- Search for an env file, starting in the current dir and looking upwards. - -- Fail if we get to the users home dir or the filesystem root. That is, - -- we don't look for an env file in the user's home dir. The user-wide - -- env lives in ghc's versionedAppDir/environments/default - findLocalEnvFile :: MaybeT IO FilePath - findLocalEnvFile = do - curdir <- liftMaybeT getCurrentDirectory - homedir <- tryMaybeT getHomeDirectory - let probe dir | isDrive dir || dir == homedir - = mzero - probe dir = do - let file = dir localEnvFileName - exists <- liftMaybeT (doesFileExist file) - if exists - then return file - else probe (takeDirectory dir) - probe curdir - - -- Error reporting - - cmdLineError :: String -> MaybeT IO a - cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " ++ show env ++ " not found" - - envError :: String -> MaybeT IO a - envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " - ++ show env - ++ " (specified in GHC_ENVIRONMENT) not found" - - -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). setTarget :: HscTarget -> DynP () @@ -5484,6 +5318,35 @@ addLdInputs :: Option -> DynFlags -> DynFlags addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} +-- ----------------------------------------------------------------------------- +-- Load dynflags from environment files. + +setFlagsFromEnvFile :: FilePath -> String -> DynP () +setFlagsFromEnvFile envfile content = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + +parseEnvFile :: FilePath -> String -> DynP () +parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgConfRef (PkgConfFile (envdir db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgConf + ["global-package-db"] -> addPkgConfRef GlobalPkgConf + ["user-package-db"] -> addPkgConfRef UserPkgConf + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + ----------------------------------------------------------------------------- -- Paths & Libraries @@ -5503,7 +5366,7 @@ addFrameworkPath p = upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) -#if !defined(mingw32_TARGET_OS) +#if !defined(mingw32_HOST_OS) split_marker :: Char split_marker = ':' -- not configurable (ToDo) #endif @@ -5515,7 +5378,7 @@ -- cause confusion when they are translated into -I options -- for passing to gcc. where -#if !defined(mingw32_TARGET_OS) +#if !defined(mingw32_HOST_OS) splitUp xs = split split_marker xs #else -- Windows: 'hybrid' support for DOS-style paths in directory lists. @@ -5700,7 +5563,7 @@ ("GHC Dynamic", showBool dynamicGhc), -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool rtsIsProfiled), - ("Debug on", show debugIsOn), + ("Debug on", showBool debugIsOn), ("LibDir", topDir dflags), -- The path of the global package database used by GHC ("Global Package DB", systemPackageConfig dflags) @@ -5909,8 +5772,6 @@ ArchX86 -> True _ -> False -isSse4_1Enabled :: DynFlags -> Bool -isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4 isSse4_2Enabled :: DynFlags -> Bool isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -640,6 +640,8 @@ -- -- To avoid adversely affecting compiler performance when timings are not -- requested, the result is only forced when timings are enabled. +-- +-- See Note [withTiming] for more. withTiming :: MonadIO m => m DynFlags -- ^ A means of getting a 'DynFlags' (often -- 'getDynFlags' will work here) @@ -749,3 +751,96 @@ <+> text cmd_line <+> text (show exn)) ; throwGhcExceptionIO (ProgramError (show exn))} + +{- Note [withTiming] +~~~~~~~~~~~~~~~~~~~~ + +For reference: + + withTiming + :: MonadIO + => m DynFlags -- how to get the DynFlags + -> SDoc -- label for the computation we're timing + -> (a -> ()) -- how to evaluate the result + -> m a -- computation we're timing + -> m a + +withTiming lets you run an action while: + +(1) measuring the CPU time it took and reporting that on stderr, +(2) emitting start/stop events to GHC's event log, with the label + given as an argument. + +Evaluation of the result +------------------------ + +'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is +to evaluate the result "sufficiently". A given pass might return an 'm a' for +some monad 'm' and result type 'a', but where the 'a' is complex enough +that evaluating it to WHNF barely scratches its surface and leaves many +complex and time-consuming computations unevaluated. Those would only be +forced by the next pass, and the time needed to evaluate them would be +mis-attributed to that next pass. A more appropriate function would be +one that deeply evaluates the result, so as to assign the time spent doing it +to the pass we're timing. + +Note: as hinted at above, the time spent evaluating the application of the +forcing function to the result is included in the timings reported by +'withTiming'. + +How we use it +------------- + +We measure the time and allocations of various passes in GHC's pipeline by just +wrapping the whole pass with 'withTiming'. This also materializes by having +a label for each pass in the eventlog, where each pass is executed in one go, +during a continuous time window. + +However, from STG onwards, the pipeline uses streams to emit groups of +STG/Cmm/etc declarations one at a time, and process them until we get to +assembly code generation. This means that the execution of those last few passes +is interleaved and that we cannot measure how long they take by just wrapping +the whole thing with 'withTiming'. Instead we wrap the processing of each +individual stream element, all along the codegen pipeline, using the appropriate +label for the pass to which this processing belongs. That generates a lot more +data but allows us to get fine-grained timings about all the passes and we can +easily compute totals withh tools like ghc-events-analyze (see below). + + +Producing an eventlog for GHC +----------------------------- + +To actually produce the eventlog, you need an eventlog-capable GHC build: + + With Hadrian: + $ hadrian/build.sh -j "stage1.ghc-bin.ghc.link.opts += -eventlog" + + With Make: + $ make -j GhcStage2HcOpts+=-eventlog + +You can then produce an eventlog when compiling say hello.hs by simply +doing: + + If GHC was built by Hadrian: + $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l + + If GHC was built with Make: + $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l + +You could alternatively use -v (with N >= 2) instead of -ddump-timings, +to ask GHC to report timings (on stderr and the eventlog). + +This will write the eventlog to ./ghc.eventlog in both cases. You can then +visualize it or look at the totals for each label by using ghc-events-analyze, +threadscope or any other eventlog consumer. Illustrating with +ghc-events-analyze: + + $ ghc-events-analyze --timed --timed-txt --totals \ + --start "GHC:started:" --stop "GHC:finished:" \ + ghc.eventlog + +This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation +of the execution through the various labels) and ghc.totals.txt (total time +spent in each label). + +-} diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -127,7 +127,7 @@ preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = cL loc $ ImportDecl { ideclExt = noExt, + = cL loc $ ImportDecl { ideclExt = noExtField, ideclSourceSrc = NoSourceText, ideclName = cL loc pRELUDE_NAME, ideclPkgQual = Nothing, diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -33,7 +33,8 @@ ForeignSrcLang(..), phaseForeignLanguage, - ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary, + ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps, + home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, SourceModified(..), isTemplateHaskellOrQQNonBoot, @@ -2799,6 +2800,28 @@ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) where mk_additional_import mod_nm = (Nothing, noLoc mod_nm) + +home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] +home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, + isLocal mb_pkg ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +-- | Like 'ms_home_imps', but for SOURCE imports. +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +-- | All of the (possibly) home module imports from a +-- 'ModSummary'; that is to say, each of these module names +-- could be a home import if an appropriately named file +-- existed. (This is in contrast to package qualified +-- imports, which are guaranteed not to be home imports.) +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -80,15 +80,18 @@ import GHC.Platform import Outputable import Maybes +import CmdLineParser import System.Environment ( getEnv ) import FastString -import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn ) +import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg, + withTiming ) import Exception import System.Directory import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix +import System.IO.Error ( isDoesNotExistError ) import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) @@ -466,7 +469,9 @@ -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) -initPackages dflags0 = do +initPackages dflags0 = withTiming (return dflags0) + (text "initializing package database") + forcePkgDb $ do dflags <- interpretPackageEnv dflags0 pkg_db <- case pkgDatabase dflags of @@ -479,6 +484,8 @@ pkgState = pkg_state, thisUnitIdInsts_ = insts }, preload) + where + forcePkgDb (dflags, _) = pkgIdMap (pkgState dflags) `seq` () -- ----------------------------------------------------------------------------- -- Reading the package database(s) @@ -2193,3 +2200,138 @@ -- in the @hs-boot@ loop-breaker. getPackageConfigMap :: DynFlags -> PackageConfigMap getPackageConfigMap = pkgIdMap . pkgState + +-- ----------------------------------------------------------------------------- +-- | Find the package environment (if one exists) +-- +-- We interpret the package environment as a set of package flags; to be +-- specific, if we find a package environment file like +-- +-- > clear-package-db +-- > global-package-db +-- > package-db blah/package.conf.d +-- > package-id id1 +-- > package-id id2 +-- +-- we interpret this as +-- +-- > [ -hide-all-packages +-- > , -clear-package-db +-- > , -global-package-db +-- > , -package-db blah/package.conf.d +-- > , -package-id id1 +-- > , -package-id id2 +-- > ] +-- +-- There's also an older syntax alias for package-id, which is just an +-- unadorned package id +-- +-- > id1 +-- > id2 +-- +interpretPackageEnv :: DynFlags -> IO DynFlags +interpretPackageEnv dflags = do + mPkgEnv <- runMaybeT $ msum $ [ + getCmdLineArg >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , cmdLineError env + ] + , getEnvVar >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , envError env + ] + , notIfHideAllPackages >> msum [ + findLocalEnvFile >>= probeEnvFile + , probeEnvName defaultEnvName + ] + ] + case mPkgEnv of + Nothing -> + -- No environment found. Leave DynFlags unchanged. + return dflags + Just "-" -> do + -- Explicitly disabled environment file. Leave DynFlags unchanged. + return dflags + Just envfile -> do + content <- readFile envfile + compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) + let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags + + return dflags' + where + -- Loading environments (by name or by location) + + namedEnvPath :: String -> MaybeT IO FilePath + namedEnvPath name = do + appdir <- versionedAppDir dflags + return $ appdir "environments" name + + probeEnvName :: String -> MaybeT IO FilePath + probeEnvName name = probeEnvFile =<< namedEnvPath name + + probeEnvFile :: FilePath -> MaybeT IO FilePath + probeEnvFile path = do + guard =<< liftMaybeT (doesFileExist path) + return path + + probeNullEnv :: FilePath -> MaybeT IO FilePath + probeNullEnv "-" = return "-" + probeNullEnv _ = mzero + + -- Various ways to define which environment to use + + getCmdLineArg :: MaybeT IO String + getCmdLineArg = MaybeT $ return $ packageEnv dflags + + getEnvVar :: MaybeT IO String + getEnvVar = do + mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" + case mvar of + Right var -> return var + Left err -> if isDoesNotExistError err then mzero + else liftMaybeT $ throwIO err + + notIfHideAllPackages :: MaybeT IO () + notIfHideAllPackages = + guard (not (gopt Opt_HideAllPackages dflags)) + + defaultEnvName :: String + defaultEnvName = "default" + + -- e.g. .ghc.environment.x86_64-linux-7.6.3 + localEnvFileName :: FilePath + localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags + + -- Search for an env file, starting in the current dir and looking upwards. + -- Fail if we get to the users home dir or the filesystem root. That is, + -- we don't look for an env file in the user's home dir. The user-wide + -- env lives in ghc's versionedAppDir/environments/default + findLocalEnvFile :: MaybeT IO FilePath + findLocalEnvFile = do + curdir <- liftMaybeT getCurrentDirectory + homedir <- tryMaybeT getHomeDirectory + let probe dir | isDrive dir || dir == homedir + = mzero + probe dir = do + let file = dir localEnvFileName + exists <- liftMaybeT (doesFileExist file) + if exists + then return file + else probe (takeDirectory dir) + probe curdir + + -- Error reporting + + cmdLineError :: String -> MaybeT IO a + cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " ++ show env ++ " not found" + + envError :: String -> MaybeT IO a + envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " + ++ show env + ++ " (specified in GHC_ENVIRONMENT) not found" diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs --- a/compiler/main/Plugins.hs +++ b/compiler/main/Plugins.hs @@ -1,5 +1,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} + +-- | Definitions for writing /plugins/ for GHC. Plugins can hook into +-- several areas of the compiler. See the 'Plugin' type. These plugins +-- include type-checker plugins, source plugins, and core-to-core plugins. + module Plugins ( -- * Plugins Plugin(..) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -131,10 +131,10 @@ import Util import ApiAnnotation import Data.List -import DynFlags ( WarningFlag(..) ) +import DynFlags ( WarningFlag(..), DynFlags ) +import ErrUtils ( Messages ) import Control.Monad -import Control.Monad.Trans.Reader import Text.ParserCombinators.ReadP as ReadP import Data.Char import qualified Data.Monoid as Monoid @@ -160,10 +160,10 @@ -- *** See Note [The Naming story] in HsDecls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (dL->L loc d) = cL loc (TyClD noExt d) +mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (dL->L loc d) = cL loc (InstD noExt d) +mkInstD (dL->L loc d) = cL loc (InstD noExtField d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -178,7 +178,7 @@ ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt + ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity , tcdFDs = snd (unLoc fds) @@ -202,7 +202,7 @@ ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataDecl { tcdDExt = noExt, + ; return (cL loc (DataDecl { tcdDExt = noExtField, tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) } @@ -217,7 +217,7 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt - ; return (HsDataDefn { dd_ext = noExt + ; return (HsDataDefn { dd_ext = noExtField , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = cxt , dd_cons = data_cons @@ -234,7 +234,7 @@ ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (SynDecl { tcdSExt = noExt + ; return (cL loc (SynDecl { tcdSExt = noExtField , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity , tcdRhs = rhs })) } @@ -246,7 +246,7 @@ mkTyFamInstEqn bndrs lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; return (mkHsImplicitBndrs - (FamEqn { feqn_ext = noExt + (FamEqn { feqn_ext = noExtField , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams @@ -266,10 +266,10 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs - (FamEqn { feqn_ext = noExt + ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs + (FamEqn { feqn_ext = noExtField , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams @@ -280,7 +280,7 @@ -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn - = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn))) + = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -293,8 +293,8 @@ ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (FamDecl noExt (FamilyDecl - { fdExt = noExt + ; return (cL loc (FamDecl noExtField (FamilyDecl + { fdExt = noExtField , fdInfo = info, fdLName = tc , fdTyVars = tyvars , fdFixity = fixity @@ -318,13 +318,13 @@ -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(dL->L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) + = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) + = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) | otherwise - = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr)) + = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan @@ -333,7 +333,7 @@ -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles - ; return $ cL loc $ RoleAnnotDecl noExt tycon roles' } + ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type @@ -387,7 +387,7 @@ = do { (mbs, sigs, fam_ds, tfam_insts , dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBinds noExt mbs sigs } + return $ ValBinds noExtField mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] @@ -473,7 +473,7 @@ -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). -has_args ((dL->L _ (XMatch _)) : _) = panic "has_args" +has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 {- ********************************************************************** @@ -588,7 +588,7 @@ do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of - PrefixCon pats -> return $ Match { m_ext = noExt + PrefixCon pats -> return $ Match { m_ext = noExtField , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where @@ -596,7 +596,7 @@ , mc_fixity = Prefix , mc_strictness = NoSrcStrict } - InfixCon p1 p2 -> return $ Match { m_ext = noExt + InfixCon p1 p2 -> return $ Match { m_ext = noExtField , m_ctxt = ctxt , m_pats = [p1, p2] , m_grhss = rhs } @@ -635,7 +635,7 @@ -> ConDecl GhcPs mkConDeclH98 name mb_forall mb_cxt args - = ConDeclH98 { con_ext = noExt + = ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc $ isJust mb_forall , con_ex_tvs = mb_forall `orElse` [] @@ -647,7 +647,7 @@ -> LHsType GhcPs -- Always a HsForAllTy -> (ConDecl GhcPs, [AddAnn]) mkGadtDecl names ty - = (ConDeclGADT { con_g_ext = noExt + = (ConDeclGADT { con_g_ext = noExtField , con_names = names , con_forall = cL l $ isLHsForAllTy ty' , con_qvars = mkHsQTvs tvs @@ -809,9 +809,9 @@ -- Check that the name space is correct! chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) - | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) + | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k)) chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) - | isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv))) + | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv))) chk t@(dL->L loc _) = addFatalError loc $ vcat [ text "Unexpected type" <+> quotes (ppr t) @@ -853,16 +853,16 @@ -- turns RuleTyTmVars into RuleBnrs - this is straightforward mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v + where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v cvt_one (RuleTyTmVar v (Just sig)) = - RuleBndrSig noExt v (mkLHsSigWcType sig) + RuleBndrSig noExtField v (mkLHsSigWcType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] mkRuleTyVarBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v) + where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExtField (fmap tm_to_ty v) cvt_one (RuleTyTmVar v (Just sig)) - = KindedTyVar noExt (fmap tm_to_ty v) sig + = KindedTyVar noExtField (fmap tm_to_ty v) sig -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" @@ -1082,7 +1082,7 @@ nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of PatBuilderPat p -> return p - PatBuilderVar x -> return (VarPat noExt x) + PatBuilderVar x -> return (VarPat noExtField x) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve @@ -1093,7 +1093,7 @@ -> do { hintBangPat loc e0 ; e' <- checkLPat e ; addAnnotation loc AnnBang lb - ; return (BangPat noExt e') } + ; return (BangPat noExtField e') } -- n+k patterns PatBuilderOpApp @@ -1109,7 +1109,7 @@ r <- checkLPat r return (ConPatIn (cL cl c) (InfixCon l r)) - PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExt)) + PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) _ -> patFail loc (ppr e0) placeHolderPunRhs :: DisambECP b => PV (Located b) @@ -1176,7 +1176,7 @@ -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun - [cL match_span (Match { m_ext = noExt + [cL match_span (Match { m_ext = noExtField , m_ctxt = FunRhs { mc_fun = fun , mc_fixity = is_infix @@ -1190,7 +1190,7 @@ -> HsBind GhcPs -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms - = FunBind { fun_ext = noExt, + = FunBind { fun_ext = noExtField, fun_id = fn, fun_matches = mkMatchGroup FromSource ms, fun_co_fn = idHsWrapper, @@ -1200,7 +1200,7 @@ -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkPatBind lhs (dL->L _ (_,grhss)) - = return ([],PatBind noExt lhs grhss ([],[])) + = return ([],PatBind noExtField lhs grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) @@ -1374,12 +1374,12 @@ | Just (strAnnId, str) <- tyElStrictness x1 , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) - , unpkAnns ++ [\s -> addAnnotation s strAnnId l1] + , unpkAnns ++ [AddAnn strAnnId l1] , xs ) pStrictMark ((dL->L l x1) : xs) | Just (strAnnId, str) <- tyElStrictness x1 = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) - , [\s -> addAnnotation s strAnnId l] + , [AddAnn strAnnId l] , xs ) pStrictMark ((dL->L l x1) : xs) | TyElUnpackedness (anns, prag, unpk) <- x1 @@ -1400,7 +1400,7 @@ Nothing -> (False, lt, pure (), xs) Just (dL->L l2 strictMark, anns, xs') -> let bl = combineSrcSpans l1 l2 - bt = HsBangTy noExt strictMark lt + bt = HsBangTy noExtField strictMark lt in (True, cL bl bt, addAnnsAt bl anns, xs') -- | Merge a /reversed/ and /non-empty/ soup of operators and operands @@ -1433,7 +1433,7 @@ ; let a = ops_acc acc' strictMark = HsSrcBang unpkSrc unpk NoSrcStrict bl = combineSrcSpans l (getLoc a) - bt = HsBangTy noExt strictMark a + bt = HsBangTy noExtField strictMark a ; addAnnsAt bl anns ; return (cL bl bt) } else addFatalError l unpkError @@ -1841,8 +1841,8 @@ mkHsInfixHolePV :: SrcSpan -> PV (Located b) instance p ~ GhcPs => DisambInfixOp (HsExpr p) where - mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExt v) - mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExt v) + mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v) + mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v) mkHsInfixHolePV l = return $ cL l hsHoleExpr instance DisambInfixOp RdrName where @@ -1973,25 +1973,25 @@ type Body (HsCmd p) = HsCmd ecpFromCmd' = return ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) - mkHsLamPV l mg = return $ cL l (HsCmdLam noExt mg) - mkHsLetPV l bs e = return $ cL l (HsCmdLet noExt bs e) + mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg) + mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e) type InfixOp (HsCmd p) = HsExpr p superInfixOp m = m mkHsOpAppPV l c1 op c2 = do - let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c - return $ cL l $ HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c mg = return $ cL l (HsCmdCase noExt c mg) + let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c + return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg) type FunArg (HsCmd p) = HsExpr p superFunArg m = m mkHsAppPV l c e = do checkCmdBlockArguments c checkExpBlockArguments e - return $ cL l (HsCmdApp noExt c e) + return $ cL l (HsCmdApp noExtField c e) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b return $ cL l (mkHsCmdIf c a b) - mkHsDoPV l stmts = return $ cL l (HsCmdDo noExt stmts) - mkHsParPV l c = return $ cL l (HsCmdPar noExt c) + mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts) + mkHsParPV l c = return $ cL l (HsCmdPar noExtField c) mkHsVarPV (dL->L l v) = cmdFail l (ppr v) mkHsLitPV (dL->L l a) = cmdFail l (ppr a) mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) @@ -2027,36 +2027,36 @@ nest 2 (ppr c) ] return (cL l hsHoleExpr) ecpFromExp' = return - mkHsLamPV l mg = return $ cL l (HsLam noExt mg) - mkHsLetPV l bs c = return $ cL l (HsLet noExt bs c) + mkHsLamPV l mg = return $ cL l (HsLam noExtField mg) + mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c) type InfixOp (HsExpr p) = HsExpr p superInfixOp m = m mkHsOpAppPV l e1 op e2 = do - return $ cL l $ OpApp noExt e1 op e2 - mkHsCasePV l e mg = return $ cL l (HsCase noExt e mg) + return $ cL l $ OpApp noExtField e1 op e2 + mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg) type FunArg (HsExpr p) = HsExpr p superFunArg m = m mkHsAppPV l e1 e2 = do checkExpBlockArguments e1 checkExpBlockArguments e2 - return $ cL l (HsApp noExt e1 e2) + return $ cL l (HsApp noExtField e1 e2) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b return $ cL l (mkHsIf c a b) - mkHsDoPV l stmts = return $ cL l (HsDo noExt DoExpr stmts) - mkHsParPV l e = return $ cL l (HsPar noExt e) - mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExt v) - mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExt a) - mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExt a) + mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts) + mkHsParPV l e = return $ cL l (HsPar noExtField e) + mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v) + mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a) + mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a) mkHsWildCardPV l = return $ cL l hsHoleExpr - mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExt a (mkLHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExt Nothing xs) - mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExt) sp + mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) + mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs) + mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp mkHsRecordPV l lrec a (fbinds, ddLoc) = do r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) checkRecordSyntax (cL l r) - mkHsNegAppPV l a = return $ cL l (NegApp noExt a noSyntaxExpr) - mkHsSectionR_PV l op e = return $ cL l (SectionR noExt op e) + mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr) + mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e) mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty mkHsAsPatPV l v e = do opt_TypeApplications <- getBit TypeApplicationsBit @@ -2077,7 +2077,7 @@ ; return (cL l hsHoleExpr) } hsHoleExpr :: HsExpr (GhcPass id) -hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) +hsHoleExpr = HsUnboundVar noExtField (TrueExprHole (mkVarOcc "_")) -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p @@ -2130,16 +2130,16 @@ mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) mkHsLitPV lit@(dL->L l a) = do checkUnboxedStringLitPat lit - return $ cL l (PatBuilderPat (LitPat noExt a)) + return $ cL l (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) - mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExt)) + mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig = do p <- checkLPat b - return $ cL l (PatBuilderPat (SigPat noExt p (mkLHsSigWcType sig))) + return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) mkHsExplicitListPV l xs = do ps <- traverse checkLPat xs - return (cL l (PatBuilderPat (ListPat noExt ps))) - mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExt sp)) + return (cL l (PatBuilderPat (ListPat noExtField ps))) + mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp)) mkHsRecordPV l _ a (fbinds, ddLoc) = do r <- mkPatRec a (mk_rec_fields fbinds ddLoc) checkRecordSyntax (cL l r) @@ -2153,13 +2153,13 @@ | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) mkHsViewPatPV l a b = do p <- checkLPat b - return $ cL l (PatBuilderPat (ViewPat noExt a p)) + return $ cL l (PatBuilderPat (ViewPat noExtField a p)) mkHsAsPatPV l v e = do p <- checkLPat e - return $ cL l (PatBuilderPat (AsPat noExt v p)) + return $ cL l (PatBuilderPat (AsPat noExtField v p)) mkHsLazyPatPV l e = do p <- checkLPat e - return $ cL l (PatBuilderPat (LazyPat noExt p)) + return $ cL l (PatBuilderPat (LazyPat noExtField p)) mkSumOrTuplePV = mkSumOrTuplePat checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () @@ -2671,13 +2671,13 @@ mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds - = RecordUpd { rupd_ext = noExt + = RecordUpd { rupd_ext = noExtField , rupd_expr = exp , rupd_flds = flds } mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds - = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds } + = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds } mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } @@ -2686,9 +2686,9 @@ mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) - = HsRecField (L loc (Unambiguous noExt rdr)) arg pun -mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _) - = panic "mk_rec_upd_field" + = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun +mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) + = noExtCon nec mk_rec_upd_field (HsRecField _ _ _) = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 @@ -2747,8 +2747,8 @@ funcTarget = CFunction (StaticTarget esrc entity' Nothing True) importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) - returnSpec spec = return $ ForD noExt $ ForeignImport - { fd_i_ext = noExt + returnSpec spec = return $ ForD noExtField $ ForeignImport + { fd_i_ext = noExtField , fd_name = v , fd_sig_ty = ty , fd_fi = spec @@ -2821,8 +2821,8 @@ -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) - = return $ ForD noExt $ - ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty + = return $ ForD noExtField $ + ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) (cL le esrc) } where @@ -2855,11 +2855,11 @@ case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExt (cL l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExt . cL l <$> nameT - ImpExpAll -> IEThingAll noExt . cL l <$> nameT + -> return $ IEVar noExtField (cL l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExtField . cL l <$> nameT + ImpExpAll -> IEThingAll noExtField . cL l <$> nameT ImpExpList xs -> - (\newName -> IEThingWith noExt (cL l newName) + (\newName -> IEThingWith noExtField (cL l newName) NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit @@ -2870,7 +2870,7 @@ (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExt (cL l newName) pos ies []) + -> IEThingWith noExtField (cL l newName) pos ies []) <$> nameT else addFatalError l (text "Illegal export form (use PatternSynonyms to enable)") @@ -3003,32 +3003,94 @@ ----------------------------------------------------------------------------- -- Misc utils --- See Note [Parser-Validator] and Note [Parser-Validator ReaderT SDoc] -newtype PV a = PV (ReaderT SDoc P a) - deriving (Functor, Applicative, Monad) +data PV_Context = + PV_Context + { pv_options :: ParserFlags + , pv_hint :: SDoc -- See Note [Parser-Validator Hint] + } +data PV_Accum = + PV_Accum + { pv_messages :: DynFlags -> Messages + , pv_annotations :: [(ApiAnnKey,[SrcSpan])] + , pv_comment_q :: [Located AnnotationComment] + , pv_annotations_comments :: [(SrcSpan,[Located AnnotationComment])] + } + +data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum + +-- See Note [Parser-Validator] +newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } + +instance Functor PV where + fmap = liftM + +instance Applicative PV where + pure a = a `seq` PV (\_ acc -> PV_Ok acc a) + (<*>) = ap + +instance Monad PV where + m >>= f = PV $ \ctx acc -> + case unPV m ctx acc of + PV_Ok acc' a -> unPV (f a) ctx acc' + PV_Failed acc' -> PV_Failed acc' + runPV :: PV a -> P a -runPV (PV m) = runReaderT m empty +runPV = runPV_msg empty runPV_msg :: SDoc -> PV a -> P a -runPV_msg msg (PV m) = runReaderT m msg +runPV_msg msg m = + P $ \s -> + let + pv_ctx = PV_Context + { pv_options = options s + , pv_hint = msg } + pv_acc = PV_Accum + { pv_messages = messages s + , pv_annotations = annotations s + , pv_comment_q = comment_q s + , pv_annotations_comments = annotations_comments s } + mkPState acc' = + s { messages = pv_messages acc' + , annotations = pv_annotations acc' + , comment_q = pv_comment_q acc' + , annotations_comments = pv_annotations_comments acc' } + in + case unPV m pv_ctx pv_acc of + PV_Ok acc' a -> POk (mkPState acc') a + PV_Failed acc' -> PFailed (mkPState acc') localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a -localPV_msg f (PV m) = PV (local f m) +localPV_msg f m = + let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in + PV (\ctx acc -> unPV m (modifyHint ctx) acc) instance MonadP PV where addError srcspan msg = - PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg) - addWarning option srcspan msg = - PV $ ReaderT $ \_ -> addWarning option srcspan msg + PV $ \ctx acc@PV_Accum{pv_messages=m} -> + let msg' = msg $$ pv_hint ctx in + PV_Ok acc{pv_messages=appendError srcspan msg' m} () + addWarning option srcspan warning = + PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} -> + PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} () addFatalError srcspan msg = - PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg) + addError srcspan msg >> PV (const PV_Failed) getBit ext = - PV $ ReaderT $ \_ -> getBit ext - addAnnsAt loc anns = - PV $ ReaderT $ \_ -> addAnnsAt loc anns + PV $ \ctx acc -> + let b = ext `xtest` pExtsBitmap (pv_options ctx) in + PV_Ok acc $! b addAnnotation l a v = - PV $ ReaderT $ \_ -> addAnnotation l a v + PV $ \_ acc -> + let + (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) + annotations_comments' = new_ann_comments ++ pv_annotations_comments acc + annotations' = ((l,a), [v]) : pv_annotations acc + acc' = acc + { pv_annotations = annotations' + , pv_comment_q = comment_q' + , pv_annotations_comments = annotations_comments' } + in + PV_Ok acc' () {- Note [Parser-Validator] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3060,7 +3122,7 @@ -} -{- Note [Parser-Validator ReaderT SDoc] +{- Note [Parser-Validator Hint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A PV computation is parametrized by a hint for error messages, which can be set depending on validation context. We use this in checkPattern to fix #984. @@ -3096,9 +3158,9 @@ Possibly caused by a missing 'do'? The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed -via ReaderT SDoc in PV. When validating in a context other than 'bindpat' (a -pattern to the left of <-), we set the hint to 'empty' and it has no effect on -the error messages. +as the 'pv_hint' field 'PV_Context'. When validating in a context other than +'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has +no effect on the error messages. -} @@ -3133,14 +3195,14 @@ -- Tuple mkSumOrTupleExpr l boxity (Tuple es) = - return $ cL l (ExplicitTuple noExt (map toTupArg es) boxity) + return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity) where toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs - toTupArg = mapLoc (maybe missingTupArg (Present noExt)) + toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) -- Sum mkSumOrTupleExpr l Unboxed (Sum alt arity e) = - return $ cL l (ExplicitSum noExt alt arity e) + return $ cL l (ExplicitSum noExtField alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) @@ -3150,7 +3212,7 @@ -- Tuple mkSumOrTuplePat l boxity (Tuple ps) = do ps' <- traverse toTupPat ps - return $ cL l (PatBuilderPat (TuplePat noExt ps' boxity)) + return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity)) where toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) toTupPat (dL -> L l p) = case p of @@ -3160,7 +3222,7 @@ -- Sum mkSumOrTuplePat l Unboxed (Sum alt arity p) = do p' <- checkLPat p - return $ cL l (PatBuilderPat (SumPat noExt p' alt arity)) + return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) @@ -3173,7 +3235,7 @@ mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs mkLHsDocTy t doc = let loc = getLoc t `combineSrcSpans` getLoc doc - in cL loc (HsDocTy noExt t doc) + in cL loc (HsDocTy noExtField t doc) mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -2024,7 +2024,7 @@ runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] liftedRepDataConKey :: Unique runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) - = map mkPreludeDataConUnique [74..86] + = map mkPreludeDataConUnique [74..88] unliftedRepDataConKeys = vecRepDataConKey : tupleRepDataConKey : @@ -2034,29 +2034,29 @@ -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecCount vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [87..92] +vecCountDataConKeys = map mkPreludeDataConUnique [89..94] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecElem vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [93..102] +vecElemDataConKeys = map mkPreludeDataConUnique [95..104] -- Typeable things kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, kindRepFunDataConKey, kindRepTYPEDataConKey, kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 103 -kindRepVarDataConKey = mkPreludeDataConUnique 104 -kindRepAppDataConKey = mkPreludeDataConUnique 105 -kindRepFunDataConKey = mkPreludeDataConUnique 106 -kindRepTYPEDataConKey = mkPreludeDataConUnique 107 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 108 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 109 +kindRepTyConAppDataConKey = mkPreludeDataConUnique 105 +kindRepVarDataConKey = mkPreludeDataConUnique 106 +kindRepAppDataConKey = mkPreludeDataConUnique 107 +kindRepFunDataConKey = mkPreludeDataConUnique 108 +kindRepTYPEDataConKey = mkPreludeDataConUnique 109 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 110 -typeLitNatDataConKey = mkPreludeDataConUnique 111 +typeLitSymbolDataConKey = mkPreludeDataConUnique 112 +typeLitNatDataConKey = mkPreludeDataConUnique 113 ---------------- Template Haskell ------------------- diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -93,9 +93,11 @@ import {-# SOURCE #-} TysWiredIn ( runtimeRepTy, unboxedTupleKind, liftedTypeKind , vecRepDataConTyCon, tupleRepDataConTyCon - , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy - , int16RepDataConTy, word16RepDataConTy - , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy + , liftedRepDataConTy, unliftedRepDataConTy + , intRepDataConTy + , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy + , wordRepDataConTy + , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy , addrRepDataConTy , floatRepDataConTy, doubleRepDataConTy , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy @@ -549,10 +551,12 @@ IntRep -> intRepDataConTy Int8Rep -> int8RepDataConTy Int16Rep -> int16RepDataConTy - WordRep -> wordRepDataConTy + Int32Rep -> int32RepDataConTy Int64Rep -> int64RepDataConTy + WordRep -> wordRepDataConTy Word8Rep -> word8RepDataConTy Word16Rep -> word16RepDataConTy + Word32Rep -> word32RepDataConTy Word64Rep -> word64RepDataConTy AddrRep -> addrRepDataConTy FloatRep -> floatRepDataConTy @@ -607,7 +611,7 @@ int32PrimTy :: Type int32PrimTy = mkTyConTy int32PrimTyCon int32PrimTyCon :: TyCon -int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep int64PrimTy :: Type int64PrimTy = mkTyConTy int64PrimTyCon @@ -632,7 +636,7 @@ word32PrimTy :: Type word32PrimTy = mkTyConTy word32PrimTyCon word32PrimTyCon :: TyCon -word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep word64PrimTy :: Type word64PrimTy = mkTyConTy word64PrimTyCon diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -108,9 +108,11 @@ vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, - int16RepDataConTy, word16RepDataConTy, - wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, + liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, @@ -182,6 +184,8 @@ in GHC.Types. All places where such lists exist should contain a reference to this Note, so a search for this Note's name should find all the lists. +See also Note [Getting from RuntimeRep to PrimRep] in RepType. + ************************************************************************ * * \subsection{Wired in type constructors} @@ -440,19 +444,13 @@ runtimeRepSimpleDataConNames :: [Name] runtimeRepSimpleDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "LiftedRep" - , fsLit "UnliftedRep" + [ fsLit "LiftedRep", fsLit "UnliftedRep" , fsLit "IntRep" + , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" , fsLit "WordRep" - , fsLit "Int8Rep" - , fsLit "Int16Rep" - , fsLit "Int64Rep" - , fsLit "Word8Rep" - , fsLit "Word16Rep" - , fsLit "Word64Rep" + , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" , fsLit "AddrRep" - , fsLit "FloatRep" - , fsLit "DoubleRep" + , fsLit "FloatRep", fsLit "DoubleRep" ] runtimeRepSimpleDataConKeys runtimeRepSimpleDataCons @@ -1152,6 +1150,7 @@ runtimeRepTyCon (RuntimeRep prim_rep_fun) where + -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [count, elem] | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) @@ -1166,6 +1165,7 @@ tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where + -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [rr_ty_list] = concatMap (runtimeRepPrimRep doc) rr_tys where @@ -1181,6 +1181,7 @@ sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where + -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [rr_ty_list] = map slotPrimRep (ubxSumRepType prim_repss) where @@ -1194,12 +1195,19 @@ sumRepDataConTyCon = promoteDataCon sumRepDataCon -- See Note [Wiring in RuntimeRep] +-- See Note [Getting from RuntimeRep to PrimRep] in RepType runtimeRepSimpleDataCons :: [DataCon] liftedRepDataCon :: DataCon runtimeRepSimpleDataCons@(liftedRepDataCon : _) = zipWithLazy mk_runtime_rep_dc - [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int16Rep, Int64Rep - , Word8Rep, Word16Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ] + [ LiftedRep, UnliftedRep + , IntRep + , Int8Rep, Int16Rep, Int32Rep, Int64Rep + , WordRep + , Word8Rep, Word16Rep, Word32Rep, Word64Rep + , AddrRep + , FloatRep, DoubleRep + ] runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name @@ -1207,13 +1215,20 @@ -- See Note [Wiring in RuntimeRep] liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, int8RepDataConTy, int16RepDataConTy, wordRepDataConTy, int64RepDataConTy, - word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, addrRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type [liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int16RepDataConTy, int64RepDataConTy, - word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, - addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy] + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy + ] = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons vecCountTyCon :: TyCon diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -19,10 +19,13 @@ liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, - int16RepDataConTy, word16RepDataConTy, - wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, - addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type +liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: Type vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy :: Type diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -260,10 +260,12 @@ primRepSlot IntRep = WordSlot primRepSlot Int8Rep = WordSlot primRepSlot Int16Rep = WordSlot +primRepSlot Int32Rep = WordSlot primRepSlot Int64Rep = Word64Slot primRepSlot WordRep = WordSlot primRepSlot Word8Rep = WordSlot primRepSlot Word16Rep = WordSlot +primRepSlot Word32Rep = WordSlot primRepSlot Word64Rep = Word64Slot primRepSlot AddrRep = WordSlot primRepSlot FloatRep = FloatSlot @@ -305,11 +307,165 @@ * * PrimRep * * -********************************************************************** -} +************************************************************************* +Note [RuntimeRep and PrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the relationship between GHC.Types.RuntimeRep +(of levity-polymorphism fame) and TyCon.PrimRep, as these types +are closely related. + +A "primitive entity" is one that can be + * stored in one register + * manipulated with one machine instruction + + +Examples include: + * a 32-bit integer + * a 32-bit float + * a 64-bit float + * a machine address (heap pointer), etc. + * a quad-float (on a machine with SIMD register and instructions) + * ...etc... + +The "representation or a primitive entity" specifies what kind of register is +needed and how many bits are required. The data type TyCon.PrimRep +enumerates all the possiblities. + +data PrimRep + = VoidRep + | LiftedRep -- ^ Lifted pointer + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + ...etc... + | VecRep Int PrimElemRep -- ^ SIMD fixed-width vector + +The Haskell source language is a bit more flexible: a single value may need multiple PrimReps. +For example + + utup :: (# Int, Int #) -> Bool + utup x = ... + +Here x :: (# Int, Int #), and that takes two registers, and two instructions to move around. +Unboxed sums are similar. + +Every Haskell expression e has a type ty, whose kind is of form TYPE rep + e :: ty :: TYPE rep +where rep :: RuntimeRep. Here rep describes the runtime representation for e's value, +but RuntimeRep has some extra cases: + +data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type + | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps + | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps + | LiftedRep -- ^ lifted; represented by a pointer + | UnliftedRep -- ^ unlifted; represented by a pointer + | IntRep -- ^ signed, word-sized value + ...etc... + +It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, +which describe unboxed products and sums respectively. RuntimeRep is defined +in the library ghc-prim:GHC.Types. It is also "wired-in" to GHC: see +TysWiredIn.runtimeRepTyCon. The unarisation pass, in StgUnarise, transforms the +program, so that that every variable has a type that has a PrimRep. For +example, unarisation transforms our utup function above, to take two Int +arguments instead of one (# Int, Int #) argument. + +See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. + +Note [VoidRep] +~~~~~~~~~~~~~~ +PrimRep contains a constructor VoidRep, while RuntimeRep does +not. Yet representations are often characterised by a list of PrimReps, +where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) + +However, after the unariser, all identifiers have exactly one PrimRep, but +void arguments still exist. Thus, PrimRep includes VoidRep to describe these +binders. Perhaps post-unariser representations (which need VoidRep) should be +a different type than pre-unariser representations (which use a list and do +not need VoidRep), but we have what we have. + +RuntimeRep instead uses TupleRep '[] to denote a void argument. When +converting a TupleRep '[] into a list of PrimReps, we get an empty list. + +Note [Getting from RuntimeRep to PrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep]. + +How do we get from an Id to the the list or PrimReps used to store it? We get +the Id's type ty (using idType), then ty's kind ki (using typeKind), then +pattern-match on ki to extract rep (in kindPrimRep), then extract the PrimRep +from the RuntimeRep (in runtimeRepPrimRep). + +We now must convert the RuntimeRep to a list of PrimReps. Let's look at two +examples: + + 1. x :: Int# + 2. y :: (# Int, Word# #) + +With these types, we can extract these kinds: + + 1. Int# :: TYPE IntRep + 2. (# Int, Word# #) :: TYPE (TupleRep [LiftedRep, WordRep]) + +In the end, we will get these PrimReps: + + 1. [IntRep] + 2. [LiftedRep, WordRep] + +It would thus seem that we should have a function somewhere of +type `RuntimeRep -> [PrimRep]`. This doesn't work though: when we +look at the argument of TYPE, we get something of type Type (of course). +RuntimeRep exists in the user's program, but not in GHC as such. +Instead, we must decompose the Type of kind RuntimeRep into tycons and +extract the PrimReps from the TyCons. This is what runtimeRepPrimRep does: +it takes a Type and returns a [PrimRep] + +runtimeRepPrimRep works by using tyConRuntimeRepInfo. That function +should be passed the TyCon produced by promoting one of the constructors +of RuntimeRep into type-level data. The RuntimeRep promoted datacons are +associated with a RuntimeRepInfo (stored directly in the PromotedDataCon +constructor of TyCon). This pairing happens in TysWiredIn. A RuntimeRepInfo +usually(*) contains a function from [Type] to [PrimRep]: the [Type] are +the arguments to the promoted datacon. These arguments are necessary +for the TupleRep and SumRep constructors, so that this process can recur, +producing a flattened list of PrimReps. Calling this extracted function +happens in runtimeRepPrimRep; the functions themselves are defined in +tupleRepDataCon and sumRepDataCon, both in TysWiredIn. + +The (*) above is to support vector representations. RuntimeRep refers +to VecCount and VecElem, whose promoted datacons have nuggets of information +related to vectors; these form the other alternatives for RuntimeRepInfo. + +Returning to our examples, the Types we get (after stripping off TYPE) are + + 1. TyConApp (PromotedDataCon "IntRep") [] + 2. TyConApp (PromotedDataCon "TupleRep") + [TyConApp (PromotedDataCon ":") + [ TyConApp (AlgTyCon "RuntimeRep") [] + , TyConApp (PromotedDataCon "LiftedRep") [] + , TyConApp (PromotedDataCon ":") + [ TyConApp (AlgTyCon "RuntimeRep") [] + , TyConApp (PromotedDataCon "WordRep") [] + , TyConApp (PromotedDataCon "'[]") + [TyConApp (AlgTyCon "RuntimeRep") []]]]] + +runtimeRepPrimRep calls tyConRuntimeRepInfo on (PromotedDataCon "IntRep"), resp. +(PromotedDataCon "TupleRep"), extracting a function that will produce the PrimReps. +In example 1, this function is passed an empty list (the empty list of args to IntRep) +and returns the PrimRep IntRep. (See the definition of runtimeRepSimpleDataCons in +TysWiredIn and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted +list as the one argument to the extracted function. The extracted function is defined +as prim_rep_fun within tupleRepDataCon in TysWiredIn. It takes one argument, decomposes +the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep +to process the LiftedRep and WordRep, concatentating the results. + +-} + -- | Discovers the primitive representation of a 'Type'. Returns -- a list of 'PrimRep': it's a list because of the possibility of -- no runtime representation (void) or multiple (unboxed tuple/sum) +-- See also Note [Getting from RuntimeRep to PrimRep] typePrimRep :: HasDebugCallStack => Type -> [PrimRep] typePrimRep ty = kindPrimRep (text "typePrimRep" <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) @@ -317,6 +473,7 @@ -- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep +-- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep @@ -325,6 +482,7 @@ -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. +-- See also Note [Getting from RuntimeRep to PrimRep] tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] tyConPrimRep tc = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) @@ -334,6 +492,7 @@ -- | Like 'tyConPrimRep', but assumed that there is precisely zero or -- one 'PrimRep' output +-- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep tyConPrimRep1 tc = case tyConPrimRep tc of [] -> VoidRep @@ -342,6 +501,7 @@ -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. +-- See also Note [Getting from RuntimeRep to PrimRep] kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] kindPrimRep doc ki | Just ki' <- coreView ki @@ -353,7 +513,7 @@ = pprPanic "kindPrimRep" (ppr ki $$ doc) -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that --- it encodes. +-- it encodes. See also Note [Getting from RuntimeRep to PrimRep] runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -366,5 +526,6 @@ -- | Convert a PrimRep back to a Type. Used only in the unariser to give types -- to fresh Ids. Really, only the type's representation matters. +-- See also Note [RuntimeRep and PrimRep] primRepToType :: PrimRep -> Type primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2587,11 +2587,9 @@ ic_skols :: [TcTyVar], -- Introduced skolems ic_info :: SkolemInfo, -- See Note [Skolems in an implication] -- See Note [Shadowing in a constraint] + ic_telescope :: Maybe SDoc, -- User-written telescope, if there is one - -- The list of skolems is order-checked - -- if and only if this is a Just. - -- See Note [Keeping scoped variables in order: Explicit] - -- in TcHsType + -- See Note [Checking telescopes] ic_given :: [EvVar], -- Given evidence variables -- (order does not matter) @@ -2708,7 +2706,43 @@ ppr (IC_Solved { ics_dead = dead }) = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) -{- +{- Note [Checking telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind-checking a /user-written/ type, we might have a "bad telescope" +like this one: + data SameKind :: forall k. k -> k -> Type + type Foo :: forall a k (b :: k). SameKind a b -> Type + +The kind of 'a' mentions 'k' which is bound after 'a'. Oops. + +Knowing this means that unification etc must have happened, so it's +convenient to detect it in the constraint solver: + +* We make a single implication constraint when kind-checking + the 'forall' in Foo's kind, something like + forall a k (b::k). { wanted constraints } + +* Having solved {wanted}, before discarding the now-solved implication, + the costraint solver checks the dependency order of the skolem + variables (ic_skols). This is done in setImplicationStatus. + +* This check is only necessary if the implication was born from a + user-written signature. If, say, it comes from checking a pattern + match that binds existentials, where the type of the data constructor + is known to be valid (it in tcConPat), no need for the check. + + So the check is done if and only if ic_telescope is (Just blah). + +* If ic_telesope is (Just d), the d::SDoc displays the original, + user-written type variables. + +* Be careful /NOT/ to discard an implication with non-Nothing + ic_telescope, even if ic_wanted is empty. We must give the + constraint solver a chance to make that bad-telesope test! Hence + the extra guard in emitResidualTvConstraint; see #16247 + +See also TcHsTYpe Note [Keeping scoped variables in order: Explicit] + Note [Needed evidence variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Th ic_need_evs field holds the free vars of ic_binds, and all the @@ -3700,7 +3734,7 @@ exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" -exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" +exprCtOrigin (XExpr nec) = noExtCon nec -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -3711,17 +3745,17 @@ | otherwise = Shouldn'tHappenOrigin "multi-way match" -matchesCtOrigin (XMatchGroup{}) = panic "matchesCtOrigin" +matchesCtOrigin (XMatchGroup nec) = noExtCon nec -- | Extract a suitable CtOrigin from guarded RHSs grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss -grhssCtOrigin (XGRHSs _) = panic "grhssCtOrigin" +grhssCtOrigin (XGRHSs nec) = noExtCon nec -- | Extract a suitable CtOrigin from a list of guarded RHSs lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e -lGRHSCtOrigin [L _ (XGRHS _)] = panic "lGRHSCtOrigin" +lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" pprCtLoc :: CtLoc -> SDoc @@ -3941,8 +3975,6 @@ lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) lookupRoleAnnot = lookupNameEnv -getRoleAnnots :: [Name] -> RoleAnnotEnv - -> ([LRoleAnnotDecl GhcRn], RoleAnnotEnv) +getRoleAnnots :: [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn] getRoleAnnots bndrs role_env - = ( mapMaybe (lookupRoleAnnot role_env) bndrs - , delListFromNameEnv role_env bndrs ) + = mapMaybe (lookupRoleAnnot role_env) bndrs diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -196,6 +196,9 @@ import Kind import TyCoRep +import TyCoSubst ( mkTvSubst, substTyWithCoVars ) +import TyCoFVs +import TyCoPpr ( pprParendTheta ) import Class import Var import ForeignCall @@ -953,78 +956,6 @@ isTyFamFree :: Type -> Bool -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts - -{- -************************************************************************ -* * - The "exact" free variables of a type -* * -************************************************************************ - -Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! - -exactTyCoVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It only matters -occasionally -- see the calls to exactTyCoVarsOfType. - -Historical note: years and years ago this function was used during -generalisation -- see #1813. But that code has long since died. --} - -exactTyCoVarsOfType :: Type -> TyCoVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyCoVarsOfType ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = goVar tv - go (TyConApp _ tys) = exactTyCoVarsOfTypes tys - go (LitTy {}) = emptyVarSet - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (FunTy _ arg res) = go arg `unionVarSet` go res - go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) - go (CastTy ty co) = go ty `unionVarSet` goCo co - go (CoercionTy co) = goCo co - - goMCo MRefl = emptyVarSet - goMCo (MCo co) = goCo co - - goCo (Refl ty) = go ty - goCo (GRefl _ ty mco) = go ty `unionVarSet` goMCo mco - goCo (TyConAppCo _ _ args)= goCos args - goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg - goCo (ForAllCo tv k_co co) - = goCo co `delVarSet` tv `unionVarSet` goCo k_co - goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (CoVarCo v) = goVar v - goCo (HoleCo h) = goVar (coHoleCoVar h) - goCo (AxiomInstCo _ _ args) = goCos args - goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 - goCo (SymCo co) = goCo co - goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 - goCo (NthCo _ _ co) = goCo co - goCo (LRCo _ co) = goCo co - goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg - goCo (KindCo co) = goCo co - goCo (SubCo co) = goCo co - goCo (AxiomRuleCo _ c) = goCos c - - goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos - - goProv UnsafeCoerceProv = emptyVarSet - goProv (PhantomProv kco) = goCo kco - goProv (ProofIrrelProv kco) = goCo kco - goProv (PluginProv _) = emptyVarSet - - goVar v = unitVarSet v `unionVarSet` go (varType v) - -exactTyCoVarsOfTypes :: [Type] -> TyVarSet -exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys anyRewritableTyVar :: Bool -- Ignore casts and coercions -> EqRel -- Ambient role diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -26,7 +26,8 @@ import GhcPrelude import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TyCoRep ( Type, PredType, pprType ) +import {-# SOURCE #-} TyCoRep ( Type, PredType ) +import {-# SOURCE #-} TyCoPpr ( pprType ) import Var import Name import BasicTypes diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -31,7 +31,8 @@ import GhcPrelude -import {-# SOURCE #-} TyCoRep ( Type, pprType ) +import {-# SOURCE #-} TyCoRep ( Type ) +import {-# SOURCE #-} TyCoPpr ( pprType ) import {-# SOURCE #-} TyCon ( TyCon ) import Outputable import FastString @@ -231,7 +232,6 @@ -- in TcTyClsDecls , cab_roles :: [Role] -- See Note [CoAxBranch roles] , cab_lhs :: [Type] -- Type patterns to match against - -- See Note [CoAxiom saturation] , cab_rhs :: Type -- Right-hand side of the equality , cab_incomps :: [CoAxBranch] -- The previous incompatible branches -- See Note [Storing compatibility] @@ -310,10 +310,7 @@ placeHolderIncomps :: [CoAxBranch] placeHolderIncomps = panic "placeHolderIncomps" -{- Note [CoAxiom saturation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* When co - +{- Note [CoAxBranch type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the case of a CoAxBranch of an associated type-family instance, diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -120,6 +120,10 @@ import IfaceType import TyCoRep +import TyCoFVs +import TyCoPpr +import TyCoSubst +import TyCoTidy import Type import TyCon import CoAxiom diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -10,6 +10,7 @@ import DynFlags import TyCoRep +import TyCoSubst import Coercion import Type hiding( substTyVarBndr, substTy ) import TcType ( exactTyCoVarsOfType ) diff --git a/compiler/types/TyCoFVs.hs b/compiler/types/TyCoFVs.hs new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoFVs.hs @@ -0,0 +1,819 @@ +module TyCoFVs + ( + tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, + exactTyCoVarsOfType, exactTyCoVarsOfTypes, + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsOfTypes, tyCoVarsOfTypesList, + tyCoVarsOfTypesSet, tyCoVarsOfCosSet, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, + tyCoVarsOfCoDSet, + tyCoFVsOfCo, tyCoFVsOfCos, + tyCoVarsOfCoList, tyCoVarsOfProv, + almostDevoidCoVarOfCo, + injectiveVarsOfType, injectiveVarsOfTypes, + + noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + + mkTyCoInScopeSet, + + -- * Welll-scoped free variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + ) where + +import GhcPrelude + +import {-# SOURCE #-} Type (coreView, tcView) + +import TyCoRep +import TyCon +import Var +import FV + +import UniqFM +import VarSet +import VarEnv +import Util +import Panic + +{- +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +{- Note [Free variables of types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns +a VarSet that is closed over the types of its variables. More precisely, + if S = tyCoVarsOfType( t ) + and (a:k) is in S + then tyCoVarsOftype( k ) is a subset of S + +Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. + +We could /not/ close over the kinds of the variable occurrences, and +instead do so at call sites, but it seems that we always want to do +so, so it's easiest to do it here. + +It turns out that getting the free variables of types is performance critical, +so we profiled several versions, exploring different implementation strategies. + +1. Baseline version: uses FV naively. Essentially: + + tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty + + This is not nice, because FV introduces some overhead to implement + determinism, and throught its "interesting var" function, neither of which + we need here, so they are a complete waste. + +2. UnionVarSet version: instead of reusing the FV-based code, we simply used + VarSets directly, trying to avoid the overhead of FV. E.g.: + + -- FV version: + tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c + + -- UnionVarSet version: + tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) + + This looks deceptively similar, but while FV internally builds a list- and + set-generating function, the VarSet functions manipulate sets directly, and + the latter peforms a lot worse than the naive FV version. + +3. Accumulator-style VarSet version: this is what we use now. We do use VarSet + as our data structure, but delegate the actual work to a new + ty_co_vars_of_... family of functions, which use accumulator style and the + "in-scope set" filter found in the internals of FV, but without the + determinism overhead. + +See #14880. + +Note [Closing over free variable kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over +free variable kinds. In previous GHC versions, this happened naively: whenever +we would encounter an occurrence of a free type variable, we would close over +its kind. This, however is wrong for two reasons (see #14880): + +1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then + we don't want to have to traverse k more than once. + +2. Correctness. Imagine we have forall k. b -> k, where b has + kind k, for some k bound in an outer scope. If we look at b's kind inside + the forall, we'll collect that k is free and then remove k from the set of + free variables. This is plain wrong. We must instead compute that b is free + and then conclude that b's kind is free. + +An obvious first approach is to move the closing-over-kinds from the +occurrences of a type variable to after finding the free vars - however, this +turns out to introduce performance regressions, and isn't even entirely +correct. + +In fact, it isn't even important *when* we close over kinds; what matters is +that we handle each type var exactly once, and that we do it in the right +context. + +So the next approach we tried was to use the "in-scope set" part of FV or the +equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to +say "don't bother with variables we have already closed over". This should work +fine in theory, but the code is complicated and doesn't perform well. + +But there is a simpler way, which is implemented here. Consider the two points +above: + +1. Efficiency: we now have an accumulator, so the second time we encounter 'a', + we'll ignore it, certainly not looking at its kind - this is why + pre-checking set membership before inserting ends up not only being faster, + but also being correct. + +2. Correctness: we have an "in-scope set" (I think we should call it it a + "bound-var set"), specifying variables that are bound by a forall in the type + we are traversing; we simply ignore these variables, certainly not looking at + their kind. + +So now consider: + + forall k. b -> k + +where b :: k->Type is free; but of course, it's a different k! When looking at +b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose +this is our first encounter with b; we want the free vars of its kind. But we +want to behave as if we took the free vars of its kind at the end; that is, +with no bound vars in scope. + +So the solution is easy. The old code was this: + + ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) + +Now all we need to do is take the free vars of tyVarKind v *with an empty +bound-var set*, thus: + +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) + ^^^^^^^^^^^ + +And that's it. + +-} + +tyCoVarsOfType :: Type -> TyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfType ty = ty_co_vars_of_type ty emptyVarSet emptyVarSet + +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = ty_co_vars_of_types tys emptyVarSet emptyVarSet + +ty_co_vars_of_type :: Type -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) + emptyVarSet -- See Note [Closing over free variable kinds] + (extendVarSet acc v) + +ty_co_vars_of_type (TyConApp _ tys) is acc = ty_co_vars_of_types tys is acc +ty_co_vars_of_type (LitTy {}) _ acc = acc +ty_co_vars_of_type (AppTy fun arg) is acc = ty_co_vars_of_type fun is (ty_co_vars_of_type arg is acc) +ty_co_vars_of_type (FunTy _ arg res) is acc = ty_co_vars_of_type arg is (ty_co_vars_of_type res is acc) +ty_co_vars_of_type (ForAllTy (Bndr tv _) ty) is acc = ty_co_vars_of_type (varType tv) is $ + ty_co_vars_of_type ty (extendVarSet is tv) acc +ty_co_vars_of_type (CastTy ty co) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_co co is acc) +ty_co_vars_of_type (CoercionTy co) is acc = ty_co_vars_of_co co is acc + +ty_co_vars_of_types :: [Type] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_types [] _ acc = acc +ty_co_vars_of_types (ty:tys) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_types tys is acc) + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCo co = ty_co_vars_of_co co emptyVarSet emptyVarSet + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = ty_co_vars_of_cos cos emptyVarSet emptyVarSet + + +ty_co_vars_of_co :: Coercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_co (Refl ty) is acc = ty_co_vars_of_type ty is acc +ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is $ + ty_co_vars_of_mco mco is acc +ty_co_vars_of_co (TyConAppCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc +ty_co_vars_of_co (AppCo co arg) is acc = ty_co_vars_of_co co is $ + ty_co_vars_of_co arg is acc +ty_co_vars_of_co (ForAllCo tv kind_co co) is acc = ty_co_vars_of_co kind_co is $ + ty_co_vars_of_co co (extendVarSet is tv) acc +ty_co_vars_of_co (FunCo _ co1 co2) is acc = ty_co_vars_of_co co1 is $ + ty_co_vars_of_co co2 is acc +ty_co_vars_of_co (CoVarCo v) is acc = ty_co_vars_of_co_var v is acc +ty_co_vars_of_co (HoleCo h) is acc = ty_co_vars_of_co_var (coHoleCoVar h) is acc + -- See Note [CoercionHoles and coercion free variables] +ty_co_vars_of_co (AxiomInstCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc +ty_co_vars_of_co (UnivCo p _ t1 t2) is acc = ty_co_vars_of_prov p is $ + ty_co_vars_of_type t1 is $ + ty_co_vars_of_type t2 is acc +ty_co_vars_of_co (SymCo co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (TransCo co1 co2) is acc = ty_co_vars_of_co co1 is $ + ty_co_vars_of_co co2 is acc +ty_co_vars_of_co (NthCo _ _ co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (LRCo _ co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (InstCo co arg) is acc = ty_co_vars_of_co co is $ + ty_co_vars_of_co arg is acc +ty_co_vars_of_co (KindCo co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (SubCo co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (AxiomRuleCo _ cs) is acc = ty_co_vars_of_cos cs is acc + +ty_co_vars_of_mco :: MCoercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_mco MRefl _is acc = acc +ty_co_vars_of_mco (MCo co) is acc = ty_co_vars_of_co co is acc + +ty_co_vars_of_co_var :: CoVar -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_co_var v is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (varType v) + emptyVarSet -- See Note [Closing over free variable kinds] + (extendVarSet acc v) + +ty_co_vars_of_cos :: [Coercion] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_cos [] _ acc = acc +ty_co_vars_of_cos (co:cos) is acc = ty_co_vars_of_co co is (ty_co_vars_of_cos cos is acc) + +tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet +tyCoVarsOfProv prov = ty_co_vars_of_prov prov emptyVarSet emptyVarSet + +ty_co_vars_of_prov :: UnivCoProvenance -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_prov (PhantomProv co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_prov (ProofIrrelProv co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_prov UnsafeCoerceProv _ acc = acc +ty_co_vars_of_prov (PluginProv _) _ acc = acc + +-- | Generates an in-scope set from the free variables in a list of types +-- and a list of coercions +mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet +mkTyCoInScopeSet tys cos + = mkInScopeSet (ty_co_vars_of_types tys emptyVarSet $ + ty_co_vars_of_cos cos emptyVarSet emptyVarSet) + +-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty + +-- | `tyCoFVsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeList :: Type -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesSet tys = tyCoVarsOfTypes $ nonDetEltsUFM tys + -- It's OK to use nonDetEltsUFM here because we immediately forget the + -- ordering by returning a set + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys + +{- +************************************************************************ +* * + The "exact" free variables of a type +* * +************************************************************************ + +Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! + +exactTyCoVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It only matters +occasionally -- see the calls to exactTyCoVarsOfType. +-} + +exactTyCoVarsOfType :: Type -> TyCoVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyCoVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = goVar tv + go (TyConApp _ tys) = exactTyCoVarsOfTypes tys + go (LitTy {}) = emptyVarSet + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (FunTy _ arg res) = go arg `unionVarSet` go res + go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) + go (CastTy ty co) = go ty `unionVarSet` goCo co + go (CoercionTy co) = goCo co + + goMCo MRefl = emptyVarSet + goMCo (MCo co) = goCo co + + goCo (Refl ty) = go ty + goCo (GRefl _ ty mco) = go ty `unionVarSet` goMCo mco + goCo (TyConAppCo _ _ args)= goCos args + goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg + goCo (ForAllCo tv k_co co) + = goCo co `delVarSet` tv `unionVarSet` goCo k_co + goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 + goCo (CoVarCo v) = goVar v + goCo (HoleCo h) = goVar (coHoleCoVar h) + goCo (AxiomInstCo _ _ args) = goCos args + goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 + goCo (SymCo co) = goCo co + goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 + goCo (NthCo _ _ co) = goCo co + goCo (LRCo _ co) = goCo co + goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg + goCo (KindCo co) = goCo co + goCo (SubCo co) = goCo co + goCo (AxiomRuleCo _ c) = goCos c + + goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos + + goProv UnsafeCoerceProv = emptyVarSet + goProv (PhantomProv kco) = goCo kco + goProv (ProofIrrelProv kco) = goCo kco + goProv (PluginProv _) = emptyVarSet + + goVar v = unitVarSet v `unionVarSet` go (varType v) + +exactTyCoVarsOfTypes :: [Type] -> TyVarSet +exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys + +-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with +-- other functions that compute free variables. +-- See Note [FV naming conventions] in FV. +-- +-- Eta-expanded because that makes it run faster (apparently) +-- See Note [FV eta expansion] in FV for explanation. +tyCoFVsOfType :: Type -> FV +-- See Note [Free variables of types] +tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) + | v `elemVarSet` bound_vars = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) + | otherwise = tyCoFVsOfType (tyVarKind v) f + emptyVarSet -- See Note [Closing over free variable kinds] + (v:acc_list, extendVarSet acc_set v) +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 (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 + +tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +-- Free vars of (forall b. ) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside + +tyCoFVsOfTypes :: [Type] -> FV +-- See Note [Free variables of types] +tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc +tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co + +tyCoFVsOfMCo :: MCoercion -> FV +tyCoFVsOfMCo MRefl = emptyFV +tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co + +tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet +tyCoVarsOfCosSet cos = tyCoVarsOfCos $ nonDetEltsUFM cos + -- It's OK to use nonDetEltsUFM here because we immediately forget the + -- ordering by returning a set + +tyCoFVsOfCo :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +-- See Note [Free variables of types] +tyCoFVsOfCo (Refl ty) fv_cand in_scope acc + = tyCoFVsOfType ty fv_cand in_scope acc +tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc + = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc +tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +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 (CoVarCo v) fv_cand in_scope acc + = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc + = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc + -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc + +tyCoFVsOfCoVar :: CoVar -> FV +tyCoFVsOfCoVar v fv_cand in_scope acc + = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + +tyCoFVsOfProv :: UnivCoProvenance -> FV +tyCoFVsOfProv UnsafeCoerceProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +tyCoFVsOfCos :: [Coercion] -> FV +tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc + + +------------- Extracting the CoVars of a type or coercion ----------- + +{- + +Note [CoVarsOfX and the InterestingVarFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The coVarsOfType, coVarsOfTypes, coVarsOfCo, and coVarsOfCos functions are +implemented in terms of the respective FV equivalents (tyCoFVsOf...), rather +than the VarSet-based flavors (tyCoVarsOf...), despite the performance +considerations outlined in Note [Free variables of types]. + +This is because FV includes the InterestingVarFun, which is useful here, +because we can cleverly use it to restrict our calculations to CoVars - this +is what getCoVarSet achieves. + +See #14880. + +-} + +getCoVarSet :: FV -> CoVarSet +getCoVarSet fv = snd (fv isCoVar emptyVarSet ([], emptyVarSet)) + +coVarsOfType :: Type -> CoVarSet +coVarsOfType ty = getCoVarSet (tyCoFVsOfType ty) + +coVarsOfTypes :: [Type] -> TyCoVarSet +coVarsOfTypes tys = getCoVarSet (tyCoFVsOfTypes tys) + +coVarsOfCo :: Coercion -> CoVarSet +coVarsOfCo co = getCoVarSet (tyCoFVsOfCo co) + +coVarsOfCos :: [Coercion] -> CoVarSet +coVarsOfCos cos = getCoVarSet (tyCoFVsOfCos cos) + +----- Whether a covar is /Almost Devoid/ in a type or coercion ---- + +-- | Given a covar and a coercion, returns True if covar is almost devoid in +-- the coercion. That is, covar can only appear in Refl and GRefl. +-- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion +almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool +almostDevoidCoVarOfCo cv co = + almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool +almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and +almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (AppCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_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 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 +almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv + = almost_devoid_co_var_of_prov p cv + && almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_type t2 cv +almost_devoid_co_var_of_co (SymCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (TransCo co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (NthCo _ _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (LRCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (InstCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (KindCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (SubCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv + +almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool +almost_devoid_co_var_of_cos [] _ = True +almost_devoid_co_var_of_cos (co:cos) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_cos cos cv + +almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool +almost_devoid_co_var_of_prov (PhantomProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (ProofIrrelProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov UnsafeCoerceProv _ = True +almost_devoid_co_var_of_prov (PluginProv _) _ = True + +almost_devoid_co_var_of_type :: Type -> CoVar -> Bool +almost_devoid_co_var_of_type (TyVarTy _) _ = True +almost_devoid_co_var_of_type (TyConApp _ tys) cv + = almost_devoid_co_var_of_types tys cv +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 res cv +almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv + = almost_devoid_co_var_of_type (varType v) cv + && (v == cv || almost_devoid_co_var_of_type ty cv) +almost_devoid_co_var_of_type (CastTy ty co) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_type (CoercionTy co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool +almost_devoid_co_var_of_types [] _ = True +almost_devoid_co_var_of_types (ty:tys) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_types tys cv + +------------- Injective free vars ----------------- + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- +-- For example, if @F@ is a non-injective type family, then: +-- +-- @ +-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} +-- @ +-- +-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. +-- More formally, if +-- @a@ is in @'injectiveVarsOfType' ty@ +-- and @S1(ty) ~ S2(ty)@, +-- then @S1(a) ~ S2(a)@, +-- where @S1@ and @S2@ are arbitrary substitutions. +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfType :: Type -> FV +injectiveVarsOfType = 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) = + case tyConInjectivityInfo tc of + NotInjective -> emptyFV + Injective inj -> mapUnionFV go $ + filterByList (inj ++ repeat True) tys + -- Oversaturated arguments to a tycon are + -- always injective, hence the repeat True + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfTypes :: [Type] -> FV +injectiveVarsOfTypes tys = mapUnionFV injectiveVarsOfType tys + +------------- No free vars ----------------- + +-- | Returns True if this type has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType (TyVarTy _) = False +noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 +noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys +noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) +noFreeVarsOfType (FunTy _ t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 +noFreeVarsOfType (LitTy _) = True +noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co +noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co + +noFreeVarsOfMCo :: MCoercion -> Bool +noFreeVarsOfMCo MRefl = True +noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co + +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes = all noFreeVarsOfType + +-- | Returns True if this coercion has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo (Refl ty) = noFreeVarsOfType ty +noFreeVarsOfCo (GRefl _ ty co) = noFreeVarsOfType ty && noFreeVarsOfMCo co +noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args +noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 +noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) +noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 +noFreeVarsOfCo (CoVarCo _) = False +noFreeVarsOfCo (HoleCo {}) = True -- I'm unsure; probably never happens +noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args +noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && + noFreeVarsOfType t1 && + noFreeVarsOfType t2 +noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (NthCo _ _ co) = noFreeVarsOfCo co +noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co +noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs + +-- | Returns True if this UnivCoProv has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. +noFreeVarsOfProv :: UnivCoProvenance -> Bool +noFreeVarsOfProv UnsafeCoerceProv = True +noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co +noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co +noFreeVarsOfProv (PluginProv {}) = True + +{- +%************************************************************************ +%* * + Well-scoped tyvars +* * +************************************************************************ + +Note [ScopedSort] +~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given [ a::k, k::*, b::k ] +-- it'll return a well-scoped list [ k::*, a::k, b::k ] +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in RnTypes + +scopedSort :: [TyCoVar] -> [TyCoVar] +scopedSort = go [] [] + where + go :: [TyCoVar] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [TyCoVar] -- yet to be sorted + -> [TyCoVar] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: TyCoVar -- var to insert + -> [TyCoVar] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([TyCoVar], [TyCoVarSet]) -- augmented lists + insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) + insert tv (a:as) (fvs:fvss) + | tv `elemVarSet` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `unionVarSet` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) + where + fv_tv = tyCoVarsOfType (tyVarKind tv) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + diff --git a/compiler/types/TyCoPpr.hs b/compiler/types/TyCoPpr.hs new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoPpr.hs @@ -0,0 +1,308 @@ +-- | Pretty-printing types and coercions. +module TyCoPpr + ( + -- * Pretty-printing + pprType, pprParendType, pprPrecType, pprPrecTypeX, + pprTypeApp, pprTCvBndr, pprTCvBndrs, + pprSigmaType, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + pprDataCons, pprWithExplicitKindsWhen, + + pprCo, pprParendCo, + + debugPprType, + ) where + +import GhcPrelude + +import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) +import {-# SOURCE #-} DataCon( dataConFullSig + , dataConUserTyVarBinders + , DataCon ) + +import TyCon +import TyCoRep +import TyCoTidy +import TyCoFVs +import Class +import Var + +import IfaceType + +import VarSet +import VarEnv + +import DynFlags ( gopt_set, GeneralFlag(Opt_PrintExplicitKinds) ) +import Outputable +import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen ) + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note that any function which pretty-prints a @Type@ first converts the @Type@ +to an @IfaceType@. See Note [IfaceType and pretty-printing] in IfaceType. + +See Note [Precedence in types] in BasicTypes. +-} + +-------------------------------------------------------- +-- When pretty-printing types, we convert to IfaceType, +-- and pretty-print that. +-- See Note [Pretty printing via IfaceSyn] in PprTyThing +-------------------------------------------------------- + +pprType, pprParendType :: Type -> SDoc +pprType = pprPrecType topPrec +pprParendType = pprPrecType appPrec + +pprPrecType :: PprPrec -> Type -> SDoc +pprPrecType = pprPrecTypeX emptyTidyEnv + +pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc +pprPrecTypeX env prec ty + = getPprStyle $ \sty -> + if debugStyle sty -- Use debugPprType when in + then debug_ppr_ty prec ty -- when in debug-style + else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) + -- NB: debug-style is used for -dppr-debug + -- dump-style is used for -ddump-tc-trace etc + +pprTyLit :: TyLit -> SDoc +pprTyLit = pprIfaceTyLit . toIfaceTyLit + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv + +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceTypeX to +-- leave them as IfaceFreeTyVar. This is super-important +-- for debug printing. +tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + where + env' = tidyFreeTyCoVars env free_tcvs + free_tcvs = tyCoVarsOfTypeWellScoped ty + +------------ +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) +pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) + +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty co sty + | userStyle sty = tidyToIfaceCo co + | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceCo :: Coercion -> IfaceCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceCoercionX to +-- leave them as IfaceFreeCoVar. This is super-important +-- for debug printing. +tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfCoList co +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta = pprIfaceContext topPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType + +------------------ +pprSigmaType :: Type -> SDoc +pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType + +pprForAll :: [TyCoVarBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) + +-- | Print a user-level forall; see Note [When to print foralls] in this module. +pprUserForAll :: [TyCoVarBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr + +pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) + +pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +-- Here we do not go via IfaceType, because the duplication with +-- pprIfaceTvBndr is minimal, and the loss of uniques etc in +-- debug printing is disastrous +pprTyVar tv + | isLiftedTypeKind kind = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) + where + kind = tyVarKind tv + +----------------- +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty topPrec ty + +debug_ppr_ty :: PprPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr 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 }) + = maybeParen prec funPrec $ + sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] + where + arrow = case af of + VisArg -> text "->" + InvisArg -> text "=>" + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec appPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) + +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec topPrec $ + hang (debug_ppr_ty topPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec funPrec $ + hang (text "forall" <+> fsep (map ppr tvs) <> dot) + -- The (map ppr tvs) will print kind-annotated + -- tvs, because we are (usually) in debug-style + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTCvBndr. + +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + user_bndrs = dataConUserTyVarBinders dc + forAllDoc = pprUserForAll user_bndrs + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType arg_tys) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys + = pprIfaceTypeApp topPrec (toIfaceTyCon tc) + (toIfaceTcArgs tc tys) + -- TODO: toIfaceTcArgs seems rather wasteful here + +------------------ +-- | Display all kind information (with @-fprint-explicit-kinds@) when the +-- provided 'Bool' argument is 'True'. +-- See @Note [Kind arguments in error messages]@ in "TcErrors". +pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc +pprWithExplicitKindsWhen b + = updSDocDynFlags $ \dflags -> + if b then gopt_set dflags Opt_PrintExplicitKinds + else dflags + diff --git a/compiler/types/TyCoPpr.hs-boot b/compiler/types/TyCoPpr.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoPpr.hs-boot @@ -0,0 +1,10 @@ +module TyCoPpr where + +import {-# SOURCE #-} TyCoRep (Type, Kind, Coercion, TyLit) +import Outputable + +pprType :: Type -> SDoc +pprKind :: Kind -> SDoc +pprCo :: Coercion -> SDoc +pprTyLit :: TyLit -> SDoc + diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -9,4079 +9,1715 @@ CoAxiom TyCon imports Class, CoAxiom TyCoRep imports Class, CoAxiom, TyCon - TysPrim imports TyCoRep ( including mkTyConTy ) - Kind imports TysPrim ( mainly for primitive kinds ) - Type imports Kind - Coercion imports Type --} - --- We expose the relevant stuff from this module via the Type module -{-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} - -module TyCoRep ( - TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, - - -- * Types - Type( TyVarTy, AppTy, TyConApp, ForAllTy - , LitTy, CastTy, CoercionTy - , FunTy, ft_arg, ft_res, ft_af - ), -- Export the type synonym FunTy too - - TyLit(..), - KindOrType, Kind, - KnotTied, - PredType, ThetaType, -- Synonyms - ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - - -- * Coercions - Coercion(..), - UnivCoProvenance(..), - CoercionHole(..), coHoleCoVar, setCoHoleCoVar, - CoercionN, CoercionR, CoercionP, KindCoercion, - MCoercion(..), MCoercionR, MCoercionN, - - -- * Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, - mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, - mkForAllTy, mkForAllTys, - mkPiTy, mkPiTys, - - kindRep_maybe, kindRep, - isLiftedTypeKind, isUnliftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, - isRuntimeRepTy, isRuntimeRepVar, - sameVis, - - -- * Functions over binders - TyCoBinder(..), TyCoVarBinder, TyBinder, - binderVar, binderVars, binderType, binderArgFlag, - delBinderVar, - isInvisibleArgFlag, isVisibleArgFlag, - isInvisibleBinder, isVisibleBinder, - isTyBinder, isNamedBinder, - - -- * Functions over coercions - pickLR, - - -- * Pretty-printing - pprType, pprParendType, pprPrecType, pprPrecTypeX, - pprTypeApp, pprTCvBndr, pprTCvBndrs, - pprSigmaType, - pprTheta, pprParendTheta, pprForAll, pprUserForAll, - pprTyVar, pprTyVars, - pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprTyLit, - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, - pprDataCons, pprWithExplicitKindsWhen, - - pprCo, pprParendCo, - - debugPprType, - - -- * Free variables - tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, - tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoFVsOfType, tyCoVarsOfTypeList, - tyCoFVsOfTypes, tyCoVarsOfTypesList, - coVarsOfType, coVarsOfTypes, - coVarsOfCo, coVarsOfCos, - tyCoVarsOfCo, tyCoVarsOfCos, - tyCoVarsOfCoDSet, - tyCoFVsOfCo, tyCoFVsOfCos, - tyCoVarsOfCoList, tyCoVarsOfProv, - almostDevoidCoVarOfCo, - injectiveVarsOfType, tyConAppNeedsKindSig, - - noFreeVarsOfType, noFreeVarsOfCo, - - -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, mkCvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendTCvSubstWithClone, - extendCvSubst, extendCvSubstWithClone, - extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, - zipTvSubst, zipCvSubst, - zipTCvSubst, - mkTvSubstPrs, - - substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, - substCoWith, - substTy, substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyWithInScope, - substTys, substTheta, - lookupTyVar, - substCo, substCos, substCoVar, substCoVars, lookupCoVar, - cloneTyVarBndr, cloneTyVarBndrs, - substVarBndr, substVarBndrs, - substTyVarBndr, substTyVarBndrs, - substCoVarBndr, - substTyVar, substTyVars, substTyCoVars, - substForAllCoBndr, - substVarBndrUsing, substForAllCoBndrUsing, - checkValidSubst, isValidTCvSubst, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyKind, - tidyCo, tidyCos, - tidyTyCoVarBinder, tidyTyCoVarBinders, - - -- * Sizes - typeSize, coercionSize, provSize - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} DataCon( dataConFullSig - , dataConUserTyVarBinders - , DataCon ) -import {-# SOURCE #-} Type( isCoercionTy, mkAppTy, mkCastTy - , tyCoVarsOfTypeWellScoped - , tyCoVarsOfTypesWellScoped - , scopedSort - , coreView ) - -- Transitively pulls in a LOT of stuff, better to break the loop - -import {-# SOURCE #-} Coercion -import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) -import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr - , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) - --- friends: -import IfaceType -import Var -import VarEnv -import VarSet -import Name hiding ( varName ) -import TyCon -import Class -import CoAxiom -import FV - --- others -import BasicTypes ( LeftOrRight(..), PprPrec(..), topPrec, sigPrec, opPrec - , funPrec, appPrec, maybeParen, pickLR ) -import PrelNames -import Outputable -import DynFlags -import FastString -import Pair -import UniqSupply -import Util -import UniqFM -import UniqSet - --- libraries -import qualified Data.Data as Data hiding ( TyCon ) -import Data.List -import Data.IORef ( IORef ) -- for CoercionHole - -{- -%************************************************************************ -%* * - TyThing -%* * -%************************************************************************ - -Despite the fact that DataCon has to be imported via a hi-boot route, -this module seems the right place for TyThing, because it's needed for -funTyCon and all the types in TysPrim. - -It is also SOURCE-imported into Name.hs - - -Note [ATyCon for classes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Both classes and type constructors are represented in the type environment -as ATyCon. You can tell the difference, and get to the class, with - isClassTyCon :: TyCon -> Bool - tyConClass_maybe :: TyCon -> Maybe Class -The Class and its associated TyCon have the same Name. --} - --- | A global typecheckable-thing, essentially anything that has a name. --- Not to be confused with a 'TcTyThing', which is also a typecheckable --- thing but in the *local* context. See 'TcEnv' for how to retrieve --- a 'TyThing' given a 'Name'. -data TyThing - = AnId Id - | AConLike ConLike - | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] - | ACoAxiom (CoAxiom Branched) - -instance Outputable TyThing where - ppr = pprShortTyThing - -instance NamedThing TyThing where -- Can't put this with the type - getName (AnId id) = getName id -- decl, because the DataCon instance - getName (ATyCon tc) = getName tc -- isn't visible there - getName (ACoAxiom cc) = getName cc - getName (AConLike cl) = conLikeName cl - -pprShortTyThing :: TyThing -> SDoc --- c.f. PprTyThing.pprTyThing, which prints all the details -pprShortTyThing thing - = pprTyThingCategory thing <+> quotes (ppr (getName thing)) - -pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory = text . capitalise . tyThingCategory - -tyThingCategory :: TyThing -> String -tyThingCategory (ATyCon tc) - | isClassTyCon tc = "class" - | otherwise = "type constructor" -tyThingCategory (ACoAxiom _) = "coercion axiom" -tyThingCategory (AnId _) = "identifier" -tyThingCategory (AConLike (RealDataCon _)) = "data constructor" -tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" - - -{- ********************************************************************** -* * - Type -* * -********************************************************************** -} - --- | The key representation of types within the compiler - -type KindOrType = Type -- See Note [Arguments to type constructors] - --- | The key type representing kinds in the compiler. -type Kind = Type - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Type - -- See Note [Non-trivial definitional equality] - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', - -- must be another 'AppTy', or 'TyVarTy' - -- See Note [Respecting definitional equality] (EQ1) about the - -- no 'CastTy' requirement - -- - -- 2) Argument type - - | TyConApp - TyCon - [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. - -- Invariant: saturated applications of 'FunTyCon' must - -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's - -- do appear as 'TyConApp's. - -- Parameters: - -- - -- 1) Type constructor being applied to. - -- - -- 2) Type arguments. Might not have enough type arguments - -- here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; - -- for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. - - | ForAllTy - {-# UNPACK #-} !TyCoVarBinder - Type -- ^ A Π type. - - | FunTy -- ^ t1 -> t2 Very common, so an important special case - -- See Note [Function types] - { ft_af :: AnonArgFlag -- Is this (->) or (=>)? - , ft_arg :: Type -- Argument type - , ft_res :: Type } -- Result type - - | LitTy TyLit -- ^ Type literals are similar to type constructors. - - | CastTy - Type - KindCoercion -- ^ A kind cast. The coercion is always nominal. - -- INVARIANT: The cast is never refl. - -- INVARIANT: The Type is not a CastTy (use TransCo instead) - -- See Note [Respecting definitional equality] (EQ2) and (EQ3) - - | CoercionTy - Coercion -- ^ Injection of a Coercion into a type - -- This should only ever be used in the RHS of an AppTy, - -- in the list of a TyConApp, when applying a promoted - -- GADT data constructor - - deriving Data.Data - --- NOTE: Other parts of the code assume that type literals do not contain --- types or type variables. -data TyLit - = NumTyLit Integer - | StrTyLit FastString - deriving (Eq, Ord, Data.Data) - - -{- Note [Function types] -~~~~~~~~~~~~~~~~~~~~~~~~ -FFunTy is the constructor for a function type. Lots of things to say -about it! - -* FFunTy is the data constructor, meaning "full function type". - -* The function type constructor (->) has kind - (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep - mkTyConApp ensure that we convert a saturated application - TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 - dropping the 'r1' and 'r2' arguments; they are easily recovered - from 't1' and 't2'. - -* The ft_af field says whether or not this is an invisible argument - VisArg: t1 -> t2 Ordinary function type - InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, - i.e. t1 :: Constraint - See Note [Types for coercions, predicates, and evidence] - - This visibility info makes no difference in Core; it matters - only when we regard the type as a Haskell source type. - -* FunTy is a (unidirectional) pattern synonym that allows - positional pattern matching (FunTy arg res), ignoring the - ArgFlag. --} - -{- ----------------------- - Commented out until the pattern match - checker can handle it; see #16185 - - For now we use the CPP macro #define FunTy FFunTy _ - (see HsVersions.h) to allow pattern matching on a - (positional) FunTy constructor. - -{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp - , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} - --- | 'FunTy' is a (uni-directional) pattern synonym for the common --- case where we want to match on the argument/result type, but --- ignoring the AnonArgFlag -pattern FunTy :: Type -> Type -> Type -pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } - - End of commented out block ----------------------------------- -} - -{- Note [Types for coercions, predicates, and evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat differently: - - (a) Predicate types - Test: isPredTy - Binders: DictIds - Kind: Constraint - Examples: (Eq a), and (a ~ b) - - (b) Coercion types are primitive, unboxed equalities - Test: isCoVarTy - Binders: CoVars (can appear in coercions) - Kind: TYPE (TupleRep []) - Examples: (t1 ~# t2) or (t1 ~R# t2) - - (c) Evidence types is the type of evidence manipulated by - the type constraint solver. - Test: isEvVarType - Binders: EvVars - Kind: Constraint or TYPE (TupleRep []) - Examples: all coercion types and predicate types - -Coercion types and predicate types are mutually exclusive, -but evidence types are a superset of both. - -When treated as a user type, - - - Predicates (of kind Constraint) are invisible and are - implicitly instantiated - - - Coercion types, and non-pred evidence types (i.e. not - of kind Constrain), are just regular old types, are - visible, and are not implicitly instantiated. - -In a FunTy { ft_af = InvisArg }, the argument type is always -a Predicate type. - -Note [Constraints in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do we allow a type constructor to have a kind like - S :: Eq a => a -> Type - -No, we do not. Doing so would mean would need a TyConApp like - S @k @(d :: Eq k) (ty :: k) - and we have no way to build, or decompose, evidence like - (d :: Eq k) at the type level. - -But we admit one exception: equality. We /do/ allow, say, - MkT :: (a ~ b) => a -> b -> Type a b - -Why? Because we can, without much difficulty. Moreover -we can promote a GADT data constructor (see TyCon -Note [Promoted data constructors]), like - data GT a b where - MkGT : a -> a -> GT a a -so programmers might reasonably expect to be able to -promote MkT as well. - -How does this work? - -* In TcValidity.checkConstraintsOK we reject kinds that - have constraints other than (a~b) and (a~~b). - -* In Inst.tcInstInvisibleTyBinder we instantiate a call - of MkT by emitting - [W] co :: alpha ~# beta - and producing the elaborated term - MkT @alpha @beta (Eq# alpha beta co) - We don't generate a boxed "Wanted"; we generate only a - regular old /unboxed/ primitive-equality Wanted, and build - the box on the spot. - -* How can we get such a MkT? By promoting a GADT-style data - constructor - data T a b where - MkT :: (a~b) => a -> b -> T a b - See DataCon.mkPromotedDataCon - and Note [Promoted data constructors] in TyCon - -* We support both homogeneous (~) and heterogeneous (~~) - equality. (See Note [The equality types story] - in TysPrim for a primer on these equality types.) - -* How do we prevent a MkT having an illegal constraint like - Eq a? We check for this at use-sites; see TcHsType.tcTyVar, - specifically dc_theta_illegal_constraint. - -* Notice that nothing special happens if - K :: (a ~# b) => blah - because (a ~# b) is not a predicate type, and is never - implicitly instantiated. (Mind you, it's not clear how you - could creates a type constructor with such a kind.) See - Note [Types for coercions, predicates, and evidence] - -* The existence of promoted MkT with an equality-constraint - argument is the (only) reason that the AnonTCB constructor - of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). - For example, when we promote the data constructor - MkT :: forall a b. (a~b) => a -> b -> T a b - we get a PromotedDataCon with tyConBinders - Bndr (a :: Type) (NamedTCB Inferred) - Bndr (b :: Type) (NamedTCB Inferred) - Bndr (_ :: a ~ b) (AnonTCB InvisArg) - Bndr (_ :: a) (AnonTCB VisArg)) - Bndr (_ :: b) (AnonTCB VisArg)) - -* One might reasonably wonder who *unpacks* these boxes once they are - made. After all, there is no type-level `case` construct. The - surprising answer is that no one ever does. Instead, if a GADT - constructor is used on the left-hand side of a type family equation, - that occurrence forces GHC to unify the types in question. For - example: - - data G a where - MkG :: G Bool - - type family F (x :: G a) :: a where - F MkG = False - - When checking the LHS `F MkG`, GHC sees the MkG constructor and then must - unify F's implicit parameter `a` with Bool. This succeeds, making the equation - - F Bool (MkG @Bool ) = False - - Note that we never need unpack the coercion. This is because type - family equations are *not* parametric in their kind variables. That - is, we could have just said - - type family H (x :: G a) :: a where - H _ = False - - The presence of False on the RHS also forces `a` to become Bool, - giving us - - H Bool _ = False - - The fact that any of this works stems from the lack of phase - separation between types and kinds (unlike the very present phase - separation between terms and types). - - Once we have the ability to pattern-match on types below top-level, - this will no longer cut it, but it seems fine for now. - - -Note [Arguments to type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of kind polymorphism, in addition to type application we now -have kind instantiation. We reuse the same notations to do so. - -For example: - - Just (* -> *) Maybe - Right * Nat Zero - -are represented by: - - TyConApp (PromotedDataCon Just) [* -> *, Maybe] - TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] - -Important note: Nat is used as a *kind* and not as a type. This can be -confusing, since type-level Nat and kind-level Nat are identical. We -use the kind of (PromotedDataCon Right) to know if its arguments are -kinds or types. - -This kind instantiation only happens in TyConApp currently. - -Note [Non-trivial definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is Int |> <*> the same as Int? YES! In order to reduce headaches, -we decide that any reflexive casts in types are just ignored. -(Indeed they must be. See Note [Respecting definitional equality].) -More generally, the `eqType` function, which defines Core's type equality -relation, ignores casts and coercion arguments, as long as the -two types have the same kind. This allows us to be a little sloppier -in keeping track of coercions, which is a good thing. It also means -that eqType does not depend on eqCoercion, which is also a good thing. - -Why is this sensible? That is, why is something different than α-equivalence -appropriate for the implementation of eqType? - -Anything smaller than ~ and homogeneous is an appropriate definition for -equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any -expression of type τ can be transmuted to one of type σ at any point by -casting. The same is true of expressions of type σ. So in some sense, τ and σ -are interchangeable. - -But let's be more precise. If we examine the typing rules of FC (say, those in -https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) -there are several places where the same metavariable is used in two different -premises to a rule. (For example, see Ty_App.) There is an implicit equality -check here. What definition of equality should we use? By convention, we use -α-equivalence. Take any rule with one (or more) of these implicit equality -checks. Then there is an admissible rule that uses ~ instead of the implicit -check, adding in casts as appropriate. - -The only problem here is that ~ is heterogeneous. To make the kinds work out -in the admissible rule that uses ~, it is necessary to homogenize the -coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; -we use η |> kind η, which is homogeneous. - -The effect of this all is that eqType, the implementation of the implicit -equality check, can use any homogeneous relation that is smaller than ~, as -those rules must also be admissible. - -A more drawn out argument around all of this is presented in Section 7.2 of -Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). - -What would go wrong if we insisted on the casts matching? See the beginning of -Section 8 in the unpublished paper above. Theoretically, nothing at all goes -wrong. But in practical terms, getting the coercions right proved to be -nightmarish. And types would explode: during kind-checking, we often produce -reflexive kind coercions. When we try to cast by these, mkCastTy just discards -them. But if we used an eqType that distinguished between Int and Int |> <*>, -then we couldn't discard -- the output of kind-checking would be enormous, -and we would need enormous casts with lots of CoherenceCo's to straighten -them out. - -Would anything go wrong if eqType respected type families? No, not at all. But -that makes eqType rather hard to implement. - -Thus, the guideline for eqType is that it should be the largest -easy-to-implement relation that is still smaller than ~ and homogeneous. The -precise choice of relation is somewhat incidental, as long as the smart -constructors and destructors in Type respect whatever relation is chosen. - -Another helpful principle with eqType is this: - - (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. - -This principle also tells us that eqType must relate only types with the -same kinds. - -Note [Respecting definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [Non-trivial definitional equality] introduces the property (EQ). -How is this upheld? - -Any function that pattern matches on all the constructors will have to -consider the possibility of CastTy. Presumably, those functions will handle -CastTy appropriately and we'll be OK. - -More dangerous are the splitXXX functions. Let's focus on splitTyConApp. -We don't want it to fail on (T a b c |> co). Happily, if we have - (T a b c |> co) `eqType` (T d e f) -then co must be reflexive. Why? eqType checks that the kinds are equal, as -well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). -By the kind check, we know that (T a b c |> co) and (T d e f) have the same -kind. So the only way that co could be non-reflexive is for (T a b c) to have -a different kind than (T d e f). But because T's kind is closed (all tycon kinds -are closed), the only way for this to happen is that one of the arguments has -to differ, leading to a contradiction. Thus, co is reflexive. - -Accordingly, by eliminating reflexive casts, splitTyConApp need not worry -about outermost casts to uphold (EQ). Eliminating reflexive casts is done -in mkCastTy. - -Unforunately, that's not the end of the story. Consider comparing - (T a b c) =? (T a b |> (co -> )) (c |> co) -These two types have the same kind (Type), but the left type is a TyConApp -while the right type is not. To handle this case, we say that the right-hand -type is ill-formed, requiring an AppTy never to have a casted TyConApp -on its left. It is easy enough to pull around the coercions to maintain -this invariant, as done in Type.mkAppTy. In the example above, trying to -form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). -Both the casts there are reflexive and will be dropped. Huzzah. - -This idea of pulling coercions to the right works for splitAppTy as well. - -However, there is one hiccup: it's possible that a coercion doesn't relate two -Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, -then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't -be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not -`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate -our (EQ) property. - -Lastly, in order to detect reflexive casts reliably, we must make sure not -to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). - -In sum, in order to uphold (EQ), we need the following three invariants: - - (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable - cast is one that relates either a FunTy to a FunTy or a - ForAllTy to a ForAllTy. - (EQ2) No reflexive casts in CastTy. - (EQ3) No nested CastTys. - (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). - See Note [Weird typing rule for ForAllTy] in Type. - -These invariants are all documented above, in the declaration for Type. - -Note [Unused coercion variable in ForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - \(co:t1 ~ t2). e - -What type should we give to this expression? - (1) forall (co:t1 ~ t2) -> t - (2) (t1 ~ t2) -> t - -If co is used in t, (1) should be the right choice. -if co is not used in t, we would like to have (1) and (2) equivalent. - -However, we want to keep eqType simple and don't want eqType (1) (2) to return -True in any case. - -We decide to always construct (2) if co is not used in t. - -Thus in mkLamType, we check whether the variable is a coercion -variable (of type (t1 ~# t2), and whether it is un-used in the -body. If so, it returns a FunTy instead of a ForAllTy. - -There are cases we want to skip the check. For example, the check is -unnecessary when it is known from the context that the input variable -is a type variable. In those cases, we use mkForAllTy. - --} - --- | A type labeled 'KnotTied' might have knot-tied tycons in it. See --- Note [Type checking recursive type and class declarations] in --- TcTyClsDecls -type KnotTied ty = ty - -{- ********************************************************************** -* * - TyCoBinder and ArgFlag -* * -********************************************************************** -} - --- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be --- dependent ('Named') or nondependent ('Anon'). They may also be visible or --- 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 - deriving Data.Data - --- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' --- in the 'Named' field. -type TyBinder = TyCoBinder - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyCoVarBinder -> VarSet -delBinderVar vars (Bndr tv _) = vars `delVarSet` tv - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyCoBinder -> Bool -isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon InvisArg _) = True -isInvisibleBinder (Anon VisArg _) = False - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyCoBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - -isNamedBinder :: TyCoBinder -> Bool -isNamedBinder (Named {}) = True -isNamedBinder (Anon {}) = False - --- | If its a named binder, is the binder a tyvar? --- Returns True for nondependent binder. --- This check that we're really returning a *Ty*Binder (as opposed to a --- coercion binder). That way, if/when we allow coercion quantification --- in more places, we'll know we missed updating some function. -isTyBinder :: TyCoBinder -> Bool -isTyBinder (Named bnd) = isTyVarBinder bnd -isTyBinder _ = True - -{- Note [TyCoBinders] -~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyCoVarBinder. But a type can be decomposed -to a telescope consisting of a [TyCoBinder] - -A TyCoBinder represents the type of binders -- that is, the type of an -argument to a Pi-type. GHC Core currently supports two different -Pi-types: - - * A non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. - - * A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty - -Both Pi-types classify terms/types that take an argument. In other -words, if `x` is either a function or a polytype, `x arg` makes sense -(for an appropriate `arg`). - - -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. - Each TyCoVarBinder - Bndr a tvis - is equipped with tvis::ArgFlag, which says whether or not arguments - for this binder should be visible (explicit) in source Haskell. - -* A TyCon contains a list of TyConBinders. Each TyConBinder - Bndr a cvis - is equipped with cvis::TyConBndrVis, which says whether or not type - and kind arguments for this TyCon should be visible (explicit) in - source Haskell. - -This table summarises the visibility rules: ---------------------------------------------------------------------------------------- -| Occurrences look like this -| GHC displays type as in Haskell source code -|-------------------------------------------------------------------------------------- -| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term -| tvis :: ArgFlag -| tvis = Inferred: f :: forall {a}. type Arg not allowed: f - f :: forall {co}. type Arg not allowed: f -| tvis = Specified: f :: forall a. type Arg optional: f or f @Int -| tvis = Required: T :: forall k -> type Arg required: T * -| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] -| -| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon -| cvis :: TyConBndrVis -| cvis = AnonTCB: T :: kind -> kind Required: T * -| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T -| T :: forall {co}. kind Arg not allowed: T -| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T -| cvis = NamedTCB Required: T :: forall k -> kind Required: T * ---------------------------------------------------------------------------------------- - -[1] In types, in the Specified case, it would make sense to allow - optional kind applications, thus (T @*), but we have not - yet implemented that - ----- In term declarations ---- - -* Inferred. Function defn, with no signature: f1 x = x - We infer f1 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because it doesn't appear in any - user-written signature for f1 - -* Specified. Function defn, with signature (implicit forall): - f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified - even though 'a' is not bound in the source code by an explicit forall - -* Specified. Function defn, with signature (explicit forall): - f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified - -* Inferred/Specified. Function signature with inferred kind polymorphism. - f4 :: a b -> Int - So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int - Here 'k' is Inferred (it's not mentioned in the type), - but 'a' and 'b' are Specified. - -* Specified. Function signature with explicit kind polymorphism - f5 :: a (b :: k) -> Int - This time 'k' is Specified, because it is mentioned explicitly, - so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int - -* Similarly pattern synonyms: - Inferred - from inferred types (e.g. no pattern type signature) - - or from inferred kind polymorphism - ----- In type declarations ---- - -* Inferred (k) - data T1 a b = MkT1 (a b) - Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * - The kind variable 'k' is Inferred, since it is not mentioned - - Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, - and Anon binders don't have a visibility flag. (Or you could think - of Anon having an implicit Required flag.) - -* Specified (k) - data T2 (a::k->*) b = MkT (a b) - Here T's kind is T :: forall (k:*). (k->*) -> k -> * - The kind variable 'k' is Specified, since it is mentioned in - the signature. - -* Required (k) - data T k (a::k->*) b = MkT (a b) - Here T's kind is T :: forall k:* -> (k->*) -> k -> * - The kind is Required, since it bound in a positional way in T's declaration - Every use of T must be explicitly applied to a kind - -* Inferred (k1), Specified (k) - data T a b (c :: k) = MkT (a b) (Proxy c) - Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * - So 'k' is Specified, because it appears explicitly, - but 'k1' is Inferred, because it does not - -Generally, in the list of TyConBinders for a TyCon, - -* Inferred arguments always come first -* Specified, Anon and Required can be mixed - -e.g. - data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... - -Here Foo's TyConBinders are - [Required 'a', Specified 'b', Anon] -and its kind prints as - Foo :: forall a -> forall b. (a -> b -> Type) -> Type - -See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls - ----- Printing ----- - - We print forall types with enough syntax to tell you their visibility - flag. But this is not source Haskell, and these types may not all - be parsable. - - Specified: a list of Specified binders is written between `forall` and `.`: - const :: forall a b. a -> b -> a - - Inferred: with -fprint-explicit-foralls, Inferred binders are written - in braces: - f :: forall {k} (a:k). S k a -> Int - Otherwise, they are printed like Specified binders. - - Required: binders are put between `forall` and `->`: - T :: forall k -> * - ----- Other points ----- - -* In classic Haskell, all named binders (that is, the type variables in - a polymorphic function type f :: forall a. a -> a) have been Inferred. - -* Inferred variables correspond to "generalized" variables from the - Visible Type Applications paper (ESOP'16). - -Note [No Required TyCoBinder in terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Required foralls for term variables, including pattern -synonyms and data constructors. Why? Because then an application -would need a /compulsory/ type argument (possibly without an "@"?), -thus (f Int); and we don't have concrete syntax for that. - -We could change this decision, but Required, Named TyCoBinders are rare -anyway. (Most are Anons.) - -However the type of a term can (just about) have a required quantifier; -see Note [Required quantifiers in the type of a term] in TcExpr. --} - - -{- ********************************************************************** -* * - PredType -* * -********************************************************************** -} - - --- | A type of the form @p@ of kind @Constraint@ represents a value whose type is --- the Haskell predicate @p@, where a predicate is what occurs before --- the @=>@ in a Haskell type. --- --- We use 'PredType' as documentation to mark those types that we guarantee to have --- this kind. --- --- It can be expanded into its representation, but: --- --- * The type checker must treat it as opaque --- --- * The rest of the compiler treats it as transparent --- --- Consider these examples: --- --- > f :: (Eq a) => a -> Int --- > g :: (?x :: Int -> Int) => a -> Int --- > h :: (r\l) => {r} => {l::Int | r} --- --- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -type PredType = Type - --- | A collection of 'PredType's -type ThetaType = [PredType] - -{- -(We don't support TREX records yet, but the setup is designed -to expand to allow them.) - -A Haskell qualified type, such as that for f,g,h above, is -represented using - * a FunTy for the double arrow - * with a type of kind Constraint as the function argument - -The predicate really does turn into a real extra argument to the -function. If the argument has type (p :: Constraint) then the predicate p is -represented by evidence of type p. - - -%************************************************************************ -%* * - Simple constructors -%* * -%************************************************************************ - -These functions are here so that they can be used by TysPrim, -which in turn is imported by Type --} - -mkTyVarTy :: TyVar -> Type -mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) - TyVarTy v - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -mkTyCoVarTy :: TyCoVar -> Type -mkTyCoVarTy v - | isTyVar v - = TyVarTy v - | otherwise - = CoercionTy (CoVarCo v) - -mkTyCoVarTys :: [TyCoVar] -> [Type] -mkTyCoVarTys = map mkTyCoVarTy - -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right - -mkFunTy :: AnonArgFlag -> Type -> Type -> Type -mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } - -mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type -mkVisFunTy = mkFunTy VisArg -mkInvisFunTy = mkFunTy InvisArg - --- | Make nested arrow types -mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type -mkVisFunTys tys ty = foldr mkVisFunTy ty tys -mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys - --- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder --- See Note [Unused coercion variable in ForAllTy] -mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty - --- | Wraps foralls over the type using the provided 'TyCoVar's from left to right -mkForAllTys :: [TyCoVarBinder] -> Type -> Type -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars - -mkPiTy:: TyCoBinder -> Type -> Type -mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } -mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty - -mkPiTys :: [TyCoBinder] -> Type -> Type -mkPiTys tbs ty = foldr mkPiTy ty tbs - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - -{- -Some basic functions, put here to break loops eg with the pretty printer --} - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @kindRep * = LiftedRep@; Panics if this is not possible. --- Treats * and Constraint as the same -kindRep :: HasDebugCallStack => Kind -> Type -kindRep k = case kindRep_maybe k of - Just r -> r - Nothing -> pprPanic "kindRep" (ppr k) - --- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. --- For example, @kindRep_maybe * = Just LiftedRep@ --- Returns 'Nothing' if the kind is not of form (TYPE rr) --- Treats * and Constraint as the same -kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type -kindRep_maybe kind - | Just kind' <- coreView kind = kindRep_maybe kind' - | TyConApp tc [arg] <- kind - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing - --- | This version considers Constraint to be the same as *. Returns True --- if the argument is equivalent to Type/Constraint and False otherwise. --- See Note [Kind Constraint and kind Type] -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - --- | Returns True if the kind classifies unlifted types and False otherwise. --- Note that this returns False for levity-polymorphic kinds, which may --- be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep - Nothing -> False - -isLiftedRuntimeRep :: Type -> Bool --- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep --- False of type variables (a :: RuntimeRep) --- and of other reps e.g. (IntRep :: RuntimeRep) -isLiftedRuntimeRep rep - | Just rep' <- coreView rep = isLiftedRuntimeRep rep' - | TyConApp rr_tc args <- rep - , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True - | otherwise = False - -isUnliftedRuntimeRep :: Type -> Bool --- True of definitely-unlifted RuntimeReps --- False of (LiftedRep :: RuntimeRep) --- and of variables (a :: RuntimeRep) -isUnliftedRuntimeRep rep - | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' - | TyConApp rr_tc _ <- rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] - = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) - -- Avoid searching all the unlifted RuntimeRep type cons - -- In the RuntimeRep data type, only LiftedRep is lifted - -- But be careful of type families (F tys) :: RuntimeRep - | otherwise {- Variables, applications -} - = False - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' -isRuntimeRepTy (TyConApp tc args) - | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True -isRuntimeRepTy _ = False - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - -{- -%************************************************************************ -%* * - Coercions -%* * -%************************************************************************ --} - --- | A 'Coercion' is concrete evidence of the equality/convertibility --- of two types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Coercion - -- Each constructor has a "role signature", indicating the way roles are - -- propagated through coercions. - -- - P, N, and R stand for coercions of the given role - -- - e stands for a coercion of a specific unknown role - -- (think "role polymorphism") - -- - "e" stands for an explicit role parameter indicating role e. - -- - _ stands for a parameter that is not a Role or Coercion. - - -- These ones mirror the shape of types - = -- Refl :: _ -> N - Refl Type -- See Note [Refl invariant] - -- Invariant: applications of (Refl T) to a bunch of identity coercions - -- always show up as Refl. - -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). - - -- Applications of (Refl T) to some coercions, at least one of - -- which is NOT the identity, show up as TyConAppCo. - -- (They may not be fully saturated however.) - -- ConAppCo coercions (like all coercions other than Refl) - -- are NEVER the identity. - - -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) - - -- GRefl :: "e" -> _ -> Maybe N -> e - -- See Note [Generalized reflexive coercion] - | GRefl Role Type MCoercionN -- See Note [Refl invariant] - -- Use (Refl ty), not (GRefl Nominal ty MRefl) - -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) - - -- These ones simply lift the correspondingly-named - -- Type constructors into Coercions - - -- TyConAppCo :: "e" -> _ -> ?? -> e - -- See Note [TyConAppCo roles] - | TyConAppCo Role TyCon [Coercion] -- lift TyConApp - -- The TyCon is never a synonym; - -- we expand synonyms eagerly - -- But it can be a type function - - | AppCo Coercion CoercionN -- lift AppTy - -- AppCo :: e -> N -> e - - -- See Note [Forall coercions] - | ForAllCo TyCoVar KindCoercion Coercion - -- ForAllCo :: _ -> N -> e -> e - - | FunCo Role Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> 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 - -- types, and that is irrelevant for coercions, which are - -- Core-only. - - -- These are special - | CoVarCo CoVar -- :: _ -> (N or R) - -- result role depends on the tycon of the variable's type - - -- AxiomInstCo :: e -> _ -> [N] -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. - -- See [Coercion axioms applied to coercions] - - | AxiomRuleCo CoAxiomRule [Coercion] - -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule - -- The number coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - - | UnivCo UnivCoProvenance Role Type Type - -- :: _ -> "e" -> _ -> _ -> e - - | SymCo Coercion -- :: e -> e - | TransCo Coercion Coercion -- :: e -> e -> e - - | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- Using NthCo on a ForAllCo gives an N coercion always - -- See Note [NthCo and newtypes] - -- - -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) - -- That is: the role of the entire coercion is redundantly cached here. - -- See Note [NthCo Cached Roles] - - | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) - -- :: _ -> N -> N - | InstCo Coercion CoercionN - -- :: e -> N -> e - -- See Note [InstCo roles] - - -- Extract a kind coercion from a (heterogeneous) type coercion - -- NB: all kind coercions are Nominal - | KindCo Coercion - -- :: e -> N - - | SubCo CoercionN -- Turns a ~N into a ~R - -- :: N -> R - - | HoleCo CoercionHole -- ^ See Note [Coercion holes] - -- Only present during typechecking - deriving Data.Data - -type CoercionN = Coercion -- always nominal -type CoercionR = Coercion -- always representational -type CoercionP = Coercion -- always phantom -type KindCoercion = CoercionN -- always nominal - --- | A semantically more meaningful type to represent what may or may not be a --- useful 'Coercion'. -data MCoercion - = MRefl - -- A trivial Reflexivity coercion - | MCo Coercion - -- Other coercions - deriving Data.Data -type MCoercionR = MCoercion -type MCoercionN = MCoercion - -instance Outputable MCoercion where - ppr MRefl = text "MRefl" - ppr (MCo co) = text "MCo" <+> ppr co - -{- -Note [Refl invariant] -~~~~~~~~~~~~~~~~~~~~~ -Invariant 1: - -Coercions have the following invariant - Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. - -You might think that a consequencs is: - Every identity coercions has Refl at the root - -But that's not quite true because of coercion variables. Consider - g where g :: Int~Int - Left h where h :: Maybe Int ~ Maybe Int -etc. So the consequence is only true of coercions that -have no coercion variables. - -Note [Generalized reflexive coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GRefl is a generalized reflexive coercion (see #15192). It wraps a kind -coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing -rules for GRefl: - - ty : k1 - ------------------------------------ - GRefl r ty MRefl: ty ~r ty - - ty : k1 co :: k1 ~ k2 - ------------------------------------ - GRefl r ty (MCo co) : ty ~r ty |> co - -Consider we have - - g1 :: s ~r t - s :: k1 - g2 :: k1 ~ k2 - -and we want to construct a coercions co which has type - - (s |> g2) ~r t - -We can define - - co = Sym (GRefl r s g2) ; g1 - -It is easy to see that - - Refl == GRefl Nominal ty MRefl :: ty ~n ty - -A nominal reflexive coercion is quite common, so we keep the special form Refl to -save allocation. - -Note [Coercion axioms applied to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The reason coercion axioms can be applied to coercions and not just -types is to allow for better optimization. There are some cases where -we need to be able to "push transitivity inside" an axiom in order to -expose further opportunities for optimization. - -For example, suppose we have - - C a : t[a] ~ F a - g : b ~ c - -and we want to optimize - - sym (C b) ; t[g] ; C c - -which has the kind - - F b ~ F c - -(stopping through t[b] and t[c] along the way). - -We'd like to optimize this to just F g -- but how? The key is -that we need to allow axioms to be instantiated by *coercions*, -not just by types. Then we can (in certain cases) push -transitivity inside the axiom instantiations, and then react -opposite-polarity instantiations of the same axiom. In this -case, e.g., we match t[g] against the LHS of (C c)'s kind, to -obtain the substitution a |-> g (note this operation is sort -of the dual of lifting!) and hence end up with - - C g : t[b] ~ F c - -which indeed has the same kind as t[g] ; C c. - -Now we have - - sym (C b) ; C g - -which can be optimized to F g. - -Note [CoAxiom index] -~~~~~~~~~~~~~~~~~~~~ -A CoAxiom has 1 or more branches. Each branch has contains a list -of the free type variables in that branch, the LHS type patterns, -and the RHS type for that branch. When we apply an axiom to a list -of coercions, we must choose which branch of the axiom we wish to -use, as the different branches may have different numbers of free -type variables. (The number of type patterns is always the same -among branches, but that doesn't quite concern us here.) - -The Int in the AxiomInstCo constructor is the 0-indexed number -of the chosen branch. - -Note [Forall coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -Constructing coercions between forall-types can be a bit tricky, -because the kinds of the bound tyvars can be different. - -The typing rule is: - - - kind_co : k1 ~ k2 - tv1:k1 |- co : t1 ~ t2 - ------------------------------------------------------------------- - ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ - all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) - -First, the TyCoVar stored in a ForAllCo is really an optimisation: this field -should be a Name, as its kind is redundant. Thinking of the field as a Name -is helpful in understanding what a ForAllCo means. -The kind of TyCoVar always matches the left-hand kind of the coercion. - -The idea is that kind_co gives the two kinds of the tyvar. See how, in the -conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. - -Of course, a type variable can't have different kinds at the same time. So, -we arbitrarily prefer the first kind when using tv1 in the inner coercion -co, which shows that t1 equals t2. - -The last wrinkle is that we need to fix the kinds in the conclusion. In -t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of -the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with -(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it -mentions the same name with different kinds, but it *is* well-kinded, noting -that `(tv1:k2) |> sym kind_co` has kind k1. - -This all really would work storing just a Name in the ForAllCo. But we can't -add Names to, e.g., VarSets, and there generally is just an impedance mismatch -in a bunch of places. So we use tv1. When we need tv2, we can use -setTyVarKind. - -Note [Predicate coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: a~b -How can we coerce between types - ([c]~a) => [a] -> c -and - ([c]~b) => [b] -> c -where the equality predicate *itself* differs? - -Answer: we simply treat (~) as an ordinary type constructor, so these -types really look like - - ((~) [c] a) -> [a] -> c - ((~) [c] b) -> [b] -> c - -So the coercion between the two is obviously - - ((~) [c] g) -> [g] -> c - -Another way to see this to say that we simply collapse predicates to -their representation type (see Type.coreView and Type.predTypeRep). - -This collapse is done by mkPredCo; there is no PredCo constructor -in Coercion. This is important because we need Nth to work on -predicates too: - Nth 1 ((~) [c] g) = g -See Simplify.simplCoercionF, which generates such selections. - -Note [Roles] -~~~~~~~~~~~~ -Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated -in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see -https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation - -Here is one way to phrase the problem: - -Given: -newtype Age = MkAge Int -type family F x -type instance F Age = Bool -type instance F Int = Char - -This compiles down to: -axAge :: Age ~ Int -axF1 :: F Age ~ Bool -axF2 :: F Int ~ Char - -Then, we can make: -(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char - -Yikes! - -The solution is _roles_, as articulated in "Generative Type Abstraction and -Type-level Computation" (POPL 2010), available at -http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf - -The specification for roles has evolved somewhat since that paper. For the -current full details, see the documentation in docs/core-spec. Here are some -highlights. - -We label every equality with a notion of type equivalence, of which there are -three options: Nominal, Representational, and Phantom. A ground type is -nominally equivalent only with itself. A newtype (which is considered a ground -type in Haskell) is representationally equivalent to its representation. -Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" -to denote the equivalences. - -The axioms above would be: -axAge :: Age ~R Int -axF1 :: F Age ~N Bool -axF2 :: F Age ~N Char - -Then, because transitivity applies only to coercions proving the same notion -of equivalence, the above construction is impossible. - -However, there is still an escape hatch: we know that any two types that are -nominally equivalent are representationally equivalent as well. This is what -the form SubCo proves -- it "demotes" a nominal equivalence into a -representational equivalence. So, it would seem the following is possible: - -sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG - -What saves us here is that the arguments to a type function F, lifted into a -coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and -we are safe. - -Roles are attached to parameters to TyCons. When lifting a TyCon into a -coercion (through TyConAppCo), we need to ensure that the arguments to the -TyCon respect their roles. For example: - -data T a b = MkT a (F b) - -If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know -that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because -the type function F branches on b's *name*, not representation. So, we say -that 'a' has role Representational and 'b' has role Nominal. The third role, -Phantom, is for parameters not used in the type's definition. Given the -following definition - -data Q a = MkQ Int - -the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we -can construct the coercion Bool ~P Char (using UnivCo). - -See the paper cited above for more examples and information. - -Note [TyConAppCo roles] -~~~~~~~~~~~~~~~~~~~~~~~ -The TyConAppCo constructor has a role parameter, indicating the role at -which the coercion proves equality. The choice of this parameter affects -the required roles of the arguments of the TyConAppCo. To help explain -it, assume the following definition: - - type instance F Int = Bool -- Axiom axF : F Int ~N Bool - newtype Age = MkAge Int -- Axiom axAge : Age ~R Int - data Foo a = MkFoo a -- Role on Foo's parameter is Representational - -TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool - For (TyConAppCo Nominal) all arguments must have role Nominal. Why? - So that Foo Age ~N Foo Int does *not* hold. - -TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool -TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int - For (TyConAppCo Representational), all arguments must have the roles - corresponding to the result of tyConRoles on the TyCon. This is the - whole point of having roles on the TyCon to begin with. So, we can - have Foo Age ~R Foo Int, if Foo's parameter has role R. - - If a Representational TyConAppCo is over-saturated (which is otherwise fine), - the spill-over arguments must all be at Nominal. This corresponds to the - behavior for AppCo. - -TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool - All arguments must have role Phantom. This one isn't strictly - necessary for soundness, but this choice removes ambiguity. - -The rules here dictate the roles of the parameters to mkTyConAppCo -(should be checked by Lint). - -Note [NthCo and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype N a = MkN Int - type role N representational - -This yields axiom - - NTCo:N :: forall a. N a ~R Int - -We can then build - - co :: forall a b. N a ~R N b - co = NTCo:N a ; sym (NTCo:N b) - -for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: - - NthCo r 0 co :: forall a b. a ~R b - -Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. - -This is not just some corner case discovered by a segfault somewhere; -it was discovered in the proof of soundness of roles and described -in the "Safe Coercions" paper (ICFP '14). - -Note [NthCo Cached Roles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we cache the role of NthCo in the NthCo constructor? -Because computing role(Nth i co) involves figuring out that - - co :: T tys1 ~ T tys2 - -using coercionKind, and finding (coercionRole co), and then looking -at the tyConRoles of T. Avoiding bad asymptotic behaviour here means -we have to compute the kind and role of a coercion simultaneously, -which makes the code complicated and inefficient. - -This only happens for NthCo. Caching the role solves the problem, and -allows coercionKind and coercionRole to be simple. - -See #11735 - -Note [InstCo roles] -~~~~~~~~~~~~~~~~~~~ -Here is (essentially) the typing rule for InstCo: - -g :: (forall a. t1) ~r (forall a. t2) -w :: s1 ~N s2 -------------------------------- InstCo -InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) - -Note that the Coercion w *must* be nominal. This is necessary -because the variable a might be used in a "nominal position" -(that is, a place where role inference would require a nominal -role) in t1 or t2. If we allowed w to be representational, we -could get bogus equalities. - -A more nuanced treatment might be able to relax this condition -somewhat, by checking if t1 and/or t2 use their bound variables -in nominal ways. If not, having w be representational is OK. - - -%************************************************************************ -%* * - UnivCoProvenance -%* * -%************************************************************************ - -A UnivCo is a coercion whose proof does not directly express its role -and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/ -no proof). - -The different kinds of UnivCo are described by UnivCoProvenance. Really -each is entirely separate, but they all share the need to represent their -role and kind, which is done in the UnivCo constructor. - --} - --- | For simplicity, we have just one UnivCo that represents a coercion from --- some type to some other type, with (in general) no restrictions on the --- type. The UnivCoProvenance specifies more exactly what the coercion really --- is and why a program should (or shouldn't!) trust the coercion. --- It is reasonable to consider each constructor of 'UnivCoProvenance' --- as a totally independent coercion form; their only commonality is --- that they don't tell you what types they coercion between. (That info --- is in the 'UnivCo' constructor of 'Coercion'. -data UnivCoProvenance - = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. - - | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom - -- roled coercions - - | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are - -- considered equivalent. See Note [ProofIrrelProv]. - -- Can be used in Nominal or Representational coercions - - | PluginProv String -- ^ From a plugin, which asserts that this coercion - -- is sound. The string is for the use of the plugin. - - deriving Data.Data - -instance Outputable UnivCoProvenance where - ppr UnsafeCoerceProv = text "(unsafeCoerce#)" - ppr (PhantomProv _) = text "(phantom)" - ppr (ProofIrrelProv _) = text "(proof irrel.)" - ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - --- | A coercion to be filled in by the type-checker. See Note [Coercion holes] -data CoercionHole - = CoercionHole { ch_co_var :: CoVar - -- See Note [CoercionHoles and coercion free variables] - - , ch_ref :: IORef (Maybe Coercion) - } - -coHoleCoVar :: CoercionHole -> CoVar -coHoleCoVar = ch_co_var - -setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole -setCoHoleCoVar h cv = h { ch_co_var = cv } - -instance Data.Data CoercionHole where - -- don't traverse? - toConstr _ = abstractConstr "CoercionHole" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "CoercionHole" - -instance Outputable CoercionHole where - ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) - - -{- Note [Phantom coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = T1 | T2 -Then we have - T s ~R T t -for any old s,t. The witness for this is (TyConAppCo T Rep co), -where (co :: s ~P t) is a phantom coercion built with PhantomProv. -The role of the UnivCo is always Phantom. The Coercion stored is the -(nominal) kind coercion between the types - kind(s) ~N kind (t) - -Note [Coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~ -During typechecking, constraint solving for type classes works by - - Generate an evidence Id, d7 :: Num a - - Wrap it in a Wanted constraint, [W] d7 :: Num a - - Use the evidence Id where the evidence is needed - - Solve the constraint later - - When solved, add an enclosing let-binding let d7 = .... in .... - which actually binds d7 to the (Num a) evidence - -For equality constraints we use a different strategy. See Note [The -equality types story] in TysPrim for background on equality constraints. - - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just - like type classes above. (Indeed, boxed equality constraints *are* classes.) - - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) - we use a different plan - -For unboxed equalities: - - Generate a CoercionHole, a mutable variable just like a unification - variable - - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest - - Use the CoercionHole in a Coercion, via HoleCo - - Solve the constraint later - - When solved, fill in the CoercionHole by side effect, instead of - doing the let-binding thing - -The main reason for all this is that there may be no good place to let-bind -the evidence for unboxed equalities: - - - We emit constraints for kind coercions, to be used to cast a - type's kind. These coercions then must be used in types. Because - they might appear in a top-level type, there is no place to bind - these (unlifted) coercions in the usual way. - - - A coercion for (forall a. t1) ~ (forall a. t2) will look like - forall a. (coercion for t1~t2) - But the coercion for (t1~t2) may mention 'a', and we don't have - let-bindings within coercions. We could add them, but coercion - holes are easier. - - - Moreover, nothing is lost from the lack of let-bindings. For - dicionaries want to achieve sharing to avoid recomoputing the - dictionary. But coercions are entirely erased, so there's little - benefit to sharing. Indeed, even if we had a let-binding, we - always inline types and coercions at every use site and drop the - binding. - -Other notes about HoleCo: - - * INVARIANT: CoercionHole and HoleCo are used only during type checking, - and should never appear in Core. Just like unification variables; a Type - can contain a TcTyVar, but only during type checking. If, one day, we - use type-level information to separate out forms that can appear during - type-checking vs forms that can appear in core proper, holes in Core will - be ruled out. - - * See Note [CoercionHoles and coercion free variables] - - * Coercion holes can be compared for equality like other coercions: - by looking at the types coerced. - - -Note [CoercionHoles and coercion free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why does a CoercionHole contain a CoVar, as well as reference to -fill in? Because we want to treat that CoVar as a free variable of -the coercion. See #14584, and Note [What prevents a -constraint from floating] in TcSimplify, item (4): - - forall k. [W] co1 :: t1 ~# t2 |> co2 - [W] co2 :: k ~# * - -Here co2 is a CoercionHole. But we /must/ know that it is free in -co1, because that's all that stops it floating outside the -implication. - - -Note [ProofIrrelProv] -~~~~~~~~~~~~~~~~~~~~~ -A ProofIrrelProv is a coercion between coercions. For example: - - data G a where - MkG :: G Bool - -In core, we get - - G :: * -> * - MkG :: forall (a :: *). (a ~ Bool) -> G a - -Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want -a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be - - TyConAppCo Nominal MkG [co3, co4] - where - co3 :: co1 ~ co2 - co4 :: a1 ~ a2 - -Note that - co1 :: a1 ~ Bool - co2 :: a2 ~ Bool - -Here, - co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) - where - co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) - co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] - - -%************************************************************************ -%* * - Free variables of types and coercions -%* * -%************************************************************************ --} - -{- Note [Free variables of types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns -a VarSet that is closed over the types of its variables. More precisely, - if S = tyCoVarsOfType( t ) - and (a:k) is in S - then tyCoVarsOftype( k ) is a subset of S - -Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. - -We could /not/ close over the kinds of the variable occurrences, and -instead do so at call sites, but it seems that we always want to do -so, so it's easiest to do it here. - -It turns out that getting the free variables of types is performance critical, -so we profiled several versions, exploring different implementation strategies. - -1. Baseline version: uses FV naively. Essentially: - - tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty - - This is not nice, because FV introduces some overhead to implement - determinism, and throught its "interesting var" function, neither of which - we need here, so they are a complete waste. - -2. UnionVarSet version: instead of reusing the FV-based code, we simply used - VarSets directly, trying to avoid the overhead of FV. E.g.: - - -- FV version: - tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c - - -- UnionVarSet version: - tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) - - This looks deceptively similar, but while FV internally builds a list- and - set-generating function, the VarSet functions manipulate sets directly, and - the latter peforms a lot worse than the naive FV version. - -3. Accumulator-style VarSet version: this is what we use now. We do use VarSet - as our data structure, but delegate the actual work to a new - ty_co_vars_of_... family of functions, which use accumulator style and the - "in-scope set" filter found in the internals of FV, but without the - determinism overhead. - -See #14880. - -Note [Closing over free variable kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over -free variable kinds. In previous GHC versions, this happened naively: whenever -we would encounter an occurrence of a free type variable, we would close over -its kind. This, however is wrong for two reasons (see #14880): - -1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then - we don't want to have to traverse k more than once. - -2. Correctness. Imagine we have forall k. b -> k, where b has - kind k, for some k bound in an outer scope. If we look at b's kind inside - the forall, we'll collect that k is free and then remove k from the set of - free variables. This is plain wrong. We must instead compute that b is free - and then conclude that b's kind is free. - -An obvious first approach is to move the closing-over-kinds from the -occurrences of a type variable to after finding the free vars - however, this -turns out to introduce performance regressions, and isn't even entirely -correct. - -In fact, it isn't even important *when* we close over kinds; what matters is -that we handle each type var exactly once, and that we do it in the right -context. - -So the next approach we tried was to use the "in-scope set" part of FV or the -equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to -say "don't bother with variables we have already closed over". This should work -fine in theory, but the code is complicated and doesn't perform well. - -But there is a simpler way, which is implemented here. Consider the two points -above: - -1. Efficiency: we now have an accumulator, so the second time we encounter 'a', - we'll ignore it, certainly not looking at its kind - this is why - pre-checking set membership before inserting ends up not only being faster, - but also being correct. - -2. Correctness: we have an "in-scope set" (I think we should call it it a - "bound-var set"), specifying variables that are bound by a forall in the type - we are traversing; we simply ignore these variables, certainly not looking at - their kind. - -So now consider: - - forall k. b -> k - -where b :: k->Type is free; but of course, it's a different k! When looking at -b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose -this is our first encounter with b; we want the free vars of its kind. But we -want to behave as if we took the free vars of its kind at the end; that is, -with no bound vars in scope. - -So the solution is easy. The old code was this: - - ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) - -Now all we need to do is take the free vars of tyVarKind v *with an empty -bound-var set*, thus: - -ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) - ^^^^^^^^^^^ - -And that's it. - --} - -tyCoVarsOfType :: Type -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfType ty = ty_co_vars_of_type ty emptyVarSet emptyVarSet - -tyCoVarsOfTypes :: [Type] -> TyCoVarSet -tyCoVarsOfTypes tys = ty_co_vars_of_types tys emptyVarSet emptyVarSet - -ty_co_vars_of_type :: Type -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) - emptyVarSet -- See Note [Closing over free variable kinds] - (extendVarSet acc v) - -ty_co_vars_of_type (TyConApp _ tys) is acc = ty_co_vars_of_types tys is acc -ty_co_vars_of_type (LitTy {}) _ acc = acc -ty_co_vars_of_type (AppTy fun arg) is acc = ty_co_vars_of_type fun is (ty_co_vars_of_type arg is acc) -ty_co_vars_of_type (FunTy _ arg res) is acc = ty_co_vars_of_type arg is (ty_co_vars_of_type res is acc) -ty_co_vars_of_type (ForAllTy (Bndr tv _) ty) is acc = ty_co_vars_of_type (varType tv) is $ - ty_co_vars_of_type ty (extendVarSet is tv) acc -ty_co_vars_of_type (CastTy ty co) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_co co is acc) -ty_co_vars_of_type (CoercionTy co) is acc = ty_co_vars_of_co co is acc - -ty_co_vars_of_types :: [Type] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_types [] _ acc = acc -ty_co_vars_of_types (ty:tys) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_types tys is acc) - -tyCoVarsOfCo :: Coercion -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCo co = ty_co_vars_of_co co emptyVarSet emptyVarSet - -tyCoVarsOfCos :: [Coercion] -> TyCoVarSet -tyCoVarsOfCos cos = ty_co_vars_of_cos cos emptyVarSet emptyVarSet - - -ty_co_vars_of_co :: Coercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_co (Refl ty) is acc = ty_co_vars_of_type ty is acc -ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is $ - ty_co_vars_of_mco mco is acc -ty_co_vars_of_co (TyConAppCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc -ty_co_vars_of_co (AppCo co arg) is acc = ty_co_vars_of_co co is $ - ty_co_vars_of_co arg is acc -ty_co_vars_of_co (ForAllCo tv kind_co co) is acc = ty_co_vars_of_co kind_co is $ - ty_co_vars_of_co co (extendVarSet is tv) acc -ty_co_vars_of_co (FunCo _ co1 co2) is acc = ty_co_vars_of_co co1 is $ - ty_co_vars_of_co co2 is acc -ty_co_vars_of_co (CoVarCo v) is acc = ty_co_vars_of_co_var v is acc -ty_co_vars_of_co (HoleCo h) is acc = ty_co_vars_of_co_var (coHoleCoVar h) is acc - -- See Note [CoercionHoles and coercion free variables] -ty_co_vars_of_co (AxiomInstCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc -ty_co_vars_of_co (UnivCo p _ t1 t2) is acc = ty_co_vars_of_prov p is $ - ty_co_vars_of_type t1 is $ - ty_co_vars_of_type t2 is acc -ty_co_vars_of_co (SymCo co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (TransCo co1 co2) is acc = ty_co_vars_of_co co1 is $ - ty_co_vars_of_co co2 is acc -ty_co_vars_of_co (NthCo _ _ co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (LRCo _ co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (InstCo co arg) is acc = ty_co_vars_of_co co is $ - ty_co_vars_of_co arg is acc -ty_co_vars_of_co (KindCo co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (SubCo co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_co (AxiomRuleCo _ cs) is acc = ty_co_vars_of_cos cs is acc - -ty_co_vars_of_mco :: MCoercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_mco MRefl _is acc = acc -ty_co_vars_of_mco (MCo co) is acc = ty_co_vars_of_co co is acc - -ty_co_vars_of_co_var :: CoVar -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_co_var v is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (varType v) - emptyVarSet -- See Note [Closing over free variable kinds] - (extendVarSet acc v) - -ty_co_vars_of_cos :: [Coercion] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_cos [] _ acc = acc -ty_co_vars_of_cos (co:cos) is acc = ty_co_vars_of_co co is (ty_co_vars_of_cos cos is acc) - -tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet -tyCoVarsOfProv prov = ty_co_vars_of_prov prov emptyVarSet emptyVarSet - -ty_co_vars_of_prov :: UnivCoProvenance -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet -ty_co_vars_of_prov (PhantomProv co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_prov (ProofIrrelProv co) is acc = ty_co_vars_of_co co is acc -ty_co_vars_of_prov UnsafeCoerceProv _ acc = acc -ty_co_vars_of_prov (PluginProv _) _ acc = acc - --- | Generates an in-scope set from the free variables in a list of types --- and a list of coercions -mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet -mkTyCoInScopeSet tys cos - = mkInScopeSet (ty_co_vars_of_types tys emptyVarSet $ - ty_co_vars_of_cos cos emptyVarSet emptyVarSet) - --- | `tyCoFVsOfType` that returns free variables of a type in a deterministic --- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty - --- | `tyCoFVsOfType` that returns free variables of a type in deterministic --- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyCoVarsOfTypeList :: Type -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesSet tys = tyCoVarsOfTypes $ nonDetEltsUFM tys - -- It's OK to use nonDetEltsUFM here because we immediately forget the - -- ordering by returning a set - --- | Returns free variables of types, including kind variables as --- a deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys - --- | Returns free variables of types, including kind variables as --- a deterministically ordered list. For type synonyms it does /not/ expand the --- synonym. -tyCoVarsOfTypesList :: [Type] -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys - --- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. --- The previous implementation used `unionVarSet` which is O(n+m) and can --- make the function quadratic. --- It's exported, so that it can be composed with --- other functions that compute free variables. --- See Note [FV naming conventions] in FV. --- --- Eta-expanded because that makes it run faster (apparently) --- See Note [FV eta expansion] in FV for explanation. -tyCoFVsOfType :: Type -> FV --- See Note [Free variables of types] -tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) - | not (f v) = (acc_list, acc_set) - | v `elemVarSet` bound_vars = (acc_list, acc_set) - | v `elemVarSet` acc_set = (acc_list, acc_set) - | otherwise = tyCoFVsOfType (tyVarKind v) f - emptyVarSet -- See Note [Closing over free variable kinds] - (v:acc_list, extendVarSet acc_set v) -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 (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 - -tyCoFVsBndr :: TyCoVarBinder -> FV -> FV --- Free vars of (forall b. ) -tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs - -tyCoFVsVarBndrs :: [Var] -> FV -> FV -tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars - -tyCoFVsVarBndr :: Var -> FV -> FV -tyCoFVsVarBndr var fvs - = tyCoFVsOfType (varType var) -- Free vars of its type/kind - `unionFV` delFV var fvs -- Delete it from the thing-inside - -tyCoFVsOfTypes :: [Type] -> FV --- See Note [Free variables of types] -tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc -tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc - --- | Get a deterministic set of the vars free in a coercion -tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co - -tyCoVarsOfCoList :: Coercion -> [TyCoVar] --- See Note [Free variables of types] -tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co - -tyCoFVsOfMCo :: MCoercion -> FV -tyCoFVsOfMCo MRefl = emptyFV -tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co - -tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet -tyCoVarsOfCosSet cos = tyCoVarsOfCos $ nonDetEltsUFM cos - -- It's OK to use nonDetEltsUFM here because we immediately forget the - -- ordering by returning a set - -tyCoFVsOfCo :: Coercion -> FV --- Extracts type and coercion variables from a coercion --- See Note [Free variables of types] -tyCoFVsOfCo (Refl ty) fv_cand in_scope acc - = tyCoFVsOfType ty fv_cand in_scope acc -tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc - = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc -tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -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 (CoVarCo v) fv_cand in_scope acc - = tyCoFVsOfCoVar v fv_cand in_scope acc -tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc - = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc - -- See Note [CoercionHoles and coercion free variables] -tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc - = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 - `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc -tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc - -tyCoFVsOfCoVar :: CoVar -> FV -tyCoFVsOfCoVar v fv_cand in_scope acc - = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc - -tyCoFVsOfProv :: UnivCoProvenance -> FV -tyCoFVsOfProv UnsafeCoerceProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc - -tyCoFVsOfCos :: [Coercion] -> FV -tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc - - -------------- Extracting the CoVars of a type or coercion ----------- - -{- - -Note [CoVarsOfX and the InterestingVarFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The coVarsOfType, coVarsOfTypes, coVarsOfCo, and coVarsOfCos functions are -implemented in terms of the respective FV equivalents (tyCoFVsOf...), rather -than the VarSet-based flavors (tyCoVarsOf...), despite the performance -considerations outlined in Note [Free variables of types]. - -This is because FV includes the InterestingVarFun, which is useful here, -because we can cleverly use it to restrict our calculations to CoVars - this -is what getCoVarSet achieves. - -See #14880. - --} - -getCoVarSet :: FV -> CoVarSet -getCoVarSet fv = snd (fv isCoVar emptyVarSet ([], emptyVarSet)) - -coVarsOfType :: Type -> CoVarSet -coVarsOfType ty = getCoVarSet (tyCoFVsOfType ty) - -coVarsOfTypes :: [Type] -> TyCoVarSet -coVarsOfTypes tys = getCoVarSet (tyCoFVsOfTypes tys) - -coVarsOfCo :: Coercion -> CoVarSet -coVarsOfCo co = getCoVarSet (tyCoFVsOfCo co) - -coVarsOfCos :: [Coercion] -> CoVarSet -coVarsOfCos cos = getCoVarSet (tyCoFVsOfCos cos) - ------ Whether a covar is /Almost Devoid/ in a type or coercion ---- - --- | Given a covar and a coercion, returns True if covar is almost devoid in --- the coercion. That is, covar can only appear in Refl and GRefl. --- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion -almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool -almostDevoidCoVarOfCo cv co = - almost_devoid_co_var_of_co co cv - -almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool -almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and -almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into - -- the coercions -almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (AppCo co arg) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_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 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 -almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv - = almost_devoid_co_var_of_prov p cv - && almost_devoid_co_var_of_type t1 cv - && almost_devoid_co_var_of_type t2 cv -almost_devoid_co_var_of_co (SymCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (TransCo co1 co2) cv - = almost_devoid_co_var_of_co co1 cv - && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (NthCo _ _ co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (LRCo _ co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (InstCo co arg) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_co arg cv -almost_devoid_co_var_of_co (KindCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (SubCo co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv - = almost_devoid_co_var_of_cos cs cv - -almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool -almost_devoid_co_var_of_cos [] _ = True -almost_devoid_co_var_of_cos (co:cos) cv - = almost_devoid_co_var_of_co co cv - && almost_devoid_co_var_of_cos cos cv - -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool -almost_devoid_co_var_of_prov (PhantomProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (ProofIrrelProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov UnsafeCoerceProv _ = True -almost_devoid_co_var_of_prov (PluginProv _) _ = True - -almost_devoid_co_var_of_type :: Type -> CoVar -> Bool -almost_devoid_co_var_of_type (TyVarTy _) _ = True -almost_devoid_co_var_of_type (TyConApp _ tys) cv - = almost_devoid_co_var_of_types tys cv -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 res cv -almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv - = almost_devoid_co_var_of_type (varType v) cv - && (v == cv || almost_devoid_co_var_of_type ty cv) -almost_devoid_co_var_of_type (CastTy ty co) cv - = almost_devoid_co_var_of_type ty cv - && almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_type (CoercionTy co) cv - = almost_devoid_co_var_of_co co cv - -almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool -almost_devoid_co_var_of_types [] _ = True -almost_devoid_co_var_of_types (ty:tys) cv - = almost_devoid_co_var_of_type ty cv - && almost_devoid_co_var_of_types tys cv - -------------- Injective free vars ----------------- - --- | Returns the free variables of a 'Type' that are in injective positions. --- For example, if @F@ is a non-injective type family, then: --- --- @ --- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} --- @ --- --- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. --- More formally, if --- @a@ is in @'injectiveVarsOfType' ty@ --- and @S1(ty) ~ S2(ty)@, --- then @S1(a) ~ S2(a)@, --- where @S1@ and @S2@ are arbitrary substitutions. --- --- See @Note [When does a tycon application need an explicit kind signature?]@. -injectiveVarsOfType :: Type -> FV -injectiveVarsOfType = 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) = - case tyConInjectivityInfo tc of - NotInjective -> emptyFV - Injective inj -> mapUnionFV go $ - filterByList (inj ++ repeat True) tys - -- Oversaturated arguments to a tycon are - -- always injective, hence the repeat True - go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty - go LitTy{} = emptyFV - go (CastTy ty _) = go ty - go CoercionTy{} = emptyFV - --- | Does a 'TyCon' (that is applied to some number of arguments) need to be --- ascribed with an explicit kind signature to resolve ambiguity if rendered as --- a source-syntax type? --- (See @Note [When does a tycon application need an explicit kind signature?]@ --- for a full explanation of what this function checks for.) - --- Morally, this function ought to belong in TyCon.hs, not TyCoRep.hs, but --- accomplishing this requires a fair deal of futzing aruond with .hs-boot --- files. -tyConAppNeedsKindSig - :: Bool -- ^ Should specified binders count towards injective positions in - -- the kind of the TyCon? (If you're using visible kind - -- applications, then you want True here. - -> TyCon - -> Int -- ^ The number of args the 'TyCon' is applied to. - -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the - -- number of arguments) -tyConAppNeedsKindSig spec_inj_pos tc n_args - | LT <- listLengthCmp tc_binders n_args - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAt n_args tc_binders - result_kind = mkTyConKind remaining_binders tc_res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injective_vars_of_binder dropped_binders - - in not (subVarSet result_vars dropped_vars) - where - tc_binders = tyConBinders tc - tc_res_kind = tyConResKind tc - - -- Returns the variables that would be fixed by knowing a TyConBinder. See - -- Note [When does a tycon application need an explicit kind signature?] - -- for a more detailed explanation of what this function does. - injective_vars_of_binder :: TyConBinder -> FV - injective_vars_of_binder (Bndr tv vis) = - case vis of - AnonTCB VisArg -> injectiveVarsOfType (varType tv) - NamedTCB argf | source_of_injectivity argf - -> unitFV tv `unionFV` injectiveVarsOfType (varType tv) - _ -> emptyFV - - source_of_injectivity Required = True - source_of_injectivity Specified = spec_inj_pos - source_of_injectivity Inferred = False - -{- -Note [When does a tycon application need an explicit kind signature?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a couple of places in GHC where we convert Core Types into forms that -more closely resemble user-written syntax. These include: - -1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) -2. Converting Types to LHsTypes (in HsUtils.typeToLHsType, or in Haddock) - -This conversion presents a challenge: how do we ensure that the resulting type -has enough kind information so as not to be ambiguous? To better motivate this -question, consider the following Core type: - - -- Foo :: Type -> Type - type Foo = Proxy Type - -There is nothing ambiguous about the RHS of Foo in Core. But if we were to, -say, reify it into a TH Type, then it's tempting to just drop the invisible -Type argument and simply return `Proxy`. But now we've lost crucial kind -information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` -or `Proxy Int` or something else! We've inadvertently introduced ambiguity. - -Unlike in other situations in GHC, we can't just turn on --fprint-explicit-kinds, as we need to produce something which has the same -structure as a source-syntax type. Moreover, we can't rely on visible kind -application, since the first kind argument to Proxy is inferred, not specified. -Our solution is to annotate certain tycons with their kinds whenever they -appear in applied form in order to resolve the ambiguity. For instance, we -would reify the RHS of Foo like so: - - type Foo = (Proxy :: Type -> Type) - -We need to devise an algorithm that determines precisely which tycons need -these explicit kind signatures. We certainly don't want to annotate _every_ -tycon with a kind signature, or else we might end up with horribly bloated -types like the following: - - (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) - -We only want to annotate tycons that absolutely require kind signatures in -order to resolve some sort of ambiguity, and nothing more. - -Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type -require a kind signature? It might require it when we need to fill in any of -T's omitted arguments. By "omitted argument", we mean one that is dropped when -reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and -specified arguments (e.g., TH reification in TcSplice), and sometimes the -omitted arguments are only the inferred ones (e.g., in HsUtils.typeToLHsType, -which reifies specified arguments through visible kind application). -Regardless, the key idea is that _some_ arguments are going to be omitted after -reification, and the only mechanism we have at our disposal for filling them in -is through explicit kind signatures. - -What do we mean by "fill in"? Let's consider this small example: - - T :: forall {k}. Type -> (k -> Type) -> k - -Moreover, we have this application of T: - - T @{j} Int aty - -When we reify this type, we omit the inferred argument @{j}. Is it fixed by the -other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then -we'll generate an equality constraint (kappa -> Type) and, assuming we can -solve it, that will fix `kappa`. (Here, `kappa` is the unification variable -that we instantiate `k` with.) - -Therefore, for any application of a tycon T to some arguments, the Question We -Must Answer is: - -* Given the first n arguments of T, do the kinds of the non-omitted arguments - fill in the omitted arguments? - -(This is still a bit hand-wavey, but we'll refine this question incrementally -as we explain more of the machinery underlying this process.) - -Answering this question is precisely the role that the `injectiveVarsOfType` -and `injective_vars_of_binder` functions exist to serve. If an omitted argument -`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing -`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a -bit.) - -More formally, if -`a` is in `injectiveVarsOfType ty` -and S1(ty) ~ S2(ty), -then S1(a) ~ S2(a), -where S1 and S2 are arbitrary substitutions. - -For example, is `F` is a non-injective type family, then - - injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} - -Now that we know what this function does, here is a second attempt at the -Question We Must Answer: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. Do the injective - variables of these binders fill in the remainder of T's kind? - -Alright, we're getting closer. Next, we need to clarify what the injective -variables of a tycon binder are. This the role that the -`injective_vars_of_binder` function serves. Here is what this function does for -each form of tycon binder: - -* Anonymous binders are injective positions. For example, in the promoted data - constructor '(:): - - '(:) :: forall a. a -> [a] -> [a] - - The second and third tyvar binders (of kinds `a` and `[a]`) are both - anonymous, so if we had '(:) 'True '[], then the kinds of 'True and - '[] would contribute to the kind of '(:) 'True '[]. Therefore, - injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. - (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) -* Named binders: - - Inferred binders are never injective positions. For example, in this data - type: - - data Proxy a - Proxy :: forall {k}. k -> Type - - If we had Proxy 'True, then the kind of 'True would not contribute to the - kind of Proxy 'True. Therefore, - injective_vars_of_binder(forall {k}. ...) = {}. - - Required binders are injective positions. For example, in this data type: - - data Wurble k (a :: k) :: k - Wurble :: forall k -> k -> k - - The first tyvar binder (of kind `forall k`) has required visibility, so if - we had Wurble (Maybe a) Nothing, then the kind of Maybe a would - contribute to the kind of Wurble (Maybe a) Nothing. Hence, - injective_vars_of_binder(forall a -> ...) = {a}. - - Specified binders /might/ be injective positions, depending on how you - approach things. Continuing the '(:) example: - - '(:) :: forall a. a -> [a] -> [a] - - Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind - of '(:) 'True '[], since it's not explicitly instantiated by the user. But - if visible kind application is enabled, then this is possible, since the - user can write '(:) @Bool 'True '[]. (In that case, - injective_vars_of_binder(forall a. ...) = {a}.) - - There are some situations where using visible kind application is appropriate - (e.g., HsUtils.typeToLHsType) and others where it is not (e.g., TH - reification), so the `injective_vars_of_binder` function is parametrized by - a Bool which decides if specified binders should be counted towards - injective positions or not. - -Now that we've defined injective_vars_of_binder, we can refine the Question We -Must Answer once more: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the remainder of T's kind? - -If the answer to this question is "no", then (T ty_1 ... ty_n) needs an -explicit kind signature, since T's kind has kind variables leftover that -aren't fixed by the non-omitted arguments. - -One last sticking point: what does "the remainder of T's kind" mean? You might -be tempted to think that it corresponds to all of the arguments in the kind of -T that would normally be instantiated by omitted arguments. But this isn't -quite right, strictly speaking. Consider the following (silly) example: - - S :: forall {k}. Type -> Type - -And suppose we have this application of S: - - S Int Bool - -The Int argument would be omitted, and -injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which -might suggest that (S Bool) needs an explicit kind signature. But -(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature -only affects the /result/ of the application, not all of the individual -arguments. So adding a kind signature here won't make a difference. Therefore, -the fourth (and final) iteration of the Question We Must Answer is: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the kind of (T ty_1 ... ty_n)? - -Phew, that was a lot of work! - -How can be sure that this is correct? That is, how can we be sure that in the -event that we leave off a kind annotation, that one could infer the kind of the -tycon application from its arguments? It's essentially a proof by induction: if -we can infer the kinds of every subtree of a type, then the whole tycon -application will have an inferrable kind--unless, of course, the remainder of -the tycon application's kind has uninstantiated kind variables. - -What happens if T is oversaturated? That is, if T's kind has fewer than n -arguments, in the case that the concrete application instantiates a result -kind variable with an arrow kind? If we run out of arguments, we do not attach -a kind annotation. This should be a rare case, indeed. Here is an example: - - data T1 :: k1 -> k2 -> * - data T2 :: k1 -> k2 -> * - - type family G (a :: k) :: k - type instance G T1 = T2 - - type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above - -Here G's kind is (forall k. k -> k), and the desugared RHS of that last -instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to -the algorithm above, there are 3 arguments to G so we should peel off 3 -arguments in G's kind. But G's kind has only two arguments. This is the -rare special case, and we choose not to annotate the application of G with -a kind signature. After all, we needn't do this, since that instance would -be reified as: - - type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool - -So the kind of G isn't ambiguous anymore due to the explicit kind annotation -on its argument. See #8953 and test th/T8953. --} - -------------- No free vars ----------------- - --- | Returns True if this type has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. -noFreeVarsOfType :: Type -> Bool -noFreeVarsOfType (TyVarTy _) = False -noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 -noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys -noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) -noFreeVarsOfType (FunTy _ t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 -noFreeVarsOfType (LitTy _) = True -noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co -noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co - -noFreeVarsOfMCo :: MCoercion -> Bool -noFreeVarsOfMCo MRefl = True -noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co - -noFreeVarsOfTypes :: [Type] -> Bool -noFreeVarsOfTypes = all noFreeVarsOfType - --- | Returns True if this coercion has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. -noFreeVarsOfCo :: Coercion -> Bool -noFreeVarsOfCo (Refl ty) = noFreeVarsOfType ty -noFreeVarsOfCo (GRefl _ ty co) = noFreeVarsOfType ty && noFreeVarsOfMCo co -noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args -noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 -noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) -noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 -noFreeVarsOfCo (CoVarCo _) = False -noFreeVarsOfCo (HoleCo {}) = True -- I'm unsure; probably never happens -noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args -noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && - noFreeVarsOfType t1 && - noFreeVarsOfType t2 -noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (NthCo _ _ co) = noFreeVarsOfCo co -noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co -noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 -noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co -noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs - --- | Returns True if this UnivCoProv has no free variables. Should be the same as --- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. -noFreeVarsOfProv :: UnivCoProvenance -> Bool -noFreeVarsOfProv UnsafeCoerceProv = True -noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co -noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co -noFreeVarsOfProv (PluginProv {}) = True - -{- -%************************************************************************ -%* * - Substitutions - Data type defined here to avoid unnecessary mutual recursion -%* * -%************************************************************************ --} - --- | Type & coercion substitution --- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Substitutions apply only once] - -- and Note [Extending the TvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] - --- | A substitution of 'Type's for 'TyVar's --- and 'Kind's for 'KindVar's -type TvSubstEnv = TyVarEnv Type - -- NB: A TvSubstEnv is used - -- both inside a TCvSubst (with the apply-once invariant - -- discussed in Note [Substitutions apply only once], - -- and also independently in the middle of matching, - -- and unification (see Types.Unify). - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - --- | A substitution of 'Coercion's for 'CoVar's -type CvSubstEnv = CoVarEnv Coercion - -{- Note [The substitution invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When calling (substTy subst ty) it should be the case that -the in-scope set in the substitution is a superset of both: - - (SIa) The free vars of the range of the substitution - (SIb) The free vars of ty minus the domain of the substitution - -The same rules apply to other substitutions (notably CoreSubst.Subst) - -* Reason for (SIa). Consider - substTy [a :-> Maybe b] (forall b. b->a) - we must rename the forall b, to get - forall b2. b2 -> Maybe b - Making 'b' part of the in-scope set forces this renaming to - take place. - -* Reason for (SIb). Consider - substTy [a :-> Maybe b] (forall b. (a,b,x)) - Then if we use the in-scope set {b}, satisfying (SIa), there is - a danger we will rename the forall'd variable to 'x' by mistake, - getting this: - forall x. (Maybe b, x, x) - Breaking (SIb) caused the bug from #11371. - -Note: if the free vars of the range of the substitution are freshly created, -then the problems of (SIa) can't happen, and so it would be sound to -ignore (SIa). - -Note [Substitutions apply only once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use TCvSubsts to instantiate things, and we might instantiate - forall a b. ty -with the types - [a, b], or [b, a]. -So the substitution might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substitution that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - ******************************************************** - *** So a substitution must be applied precisely once *** - ******************************************************** - -A TCvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubstEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tcvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the subst envs are empty: -if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) -holds --- then (substTy subst ty) does nothing. - -For example, consider: - (/\a. /\b:(a~Int). ...b..) Int -We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's kind does change - -This invariant has several crucial consequences: - -* In substVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - -Note [Substituting types and coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types and coercions are mutually recursive, and either may have variables -"belonging" to the other. Thus, every time we wish to substitute in a -type, we may also need to substitute in a coercion, and vice versa. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. - -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with -CoercionTy. --} - -emptyTvSubstEnv :: TvSubstEnv -emptyTvSubstEnv = emptyVarEnv - -emptyCvSubstEnv :: CvSubstEnv -emptyCvSubstEnv = emptyVarEnv - -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - --- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 - where - is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) - -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv - -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv - -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv - -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv - -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv - -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst --- ^ Make a TCvSubst with specified covar subst and empty tyvar subst -mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv - -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env - -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env - -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope - --- | Returns the free variables of the types in the range of a substitution as --- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs - where - tenvFVs = tyCoVarsOfTypesSet tenv - cenvFVs = tyCoVarsOfCosSet cenv - -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v (TCvSubst _ tenv cenv) - | isTyVar v - = not (v `elemVarEnv` tenv) - | otherwise - = not (v `elemVarEnv` cenv) - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv - -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv - -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv - -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv - -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv - -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv - -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst -extendTCvSubst subst v ty - | isTyVar v - = extendTvSubst subst v ty - | CoercionTy co <- ty - = extendCvSubst subst v co - | otherwise - = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) - -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst -extendTCvSubstWithClone subst tcv - | isTyVar tcv = extendTvSubstWithClone subst tcv - | otherwise = extendCvSubstWithClone subst tcv - -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv - -extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst -extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty - = ASSERT( isTyVar v ) - extendTvSubstAndInScope subst v ty -extendTvSubstBinderAndInScope subst (Anon {}) _ - = subst - -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst --- Adds a new tv -> tv mapping, /and/ extends the in-scope set -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - (extendVarEnv tenv tv (mkTyVarTy tv')) - cenv - where - new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' - -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) - -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) - tenv - (extendVarEnv cenv cv (mkCoVarCo cv')) - where - new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' - -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst --- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) - (extendVarEnv tenv tv ty) - cenv - -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys - -extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTCvSubstList subst tvs tys - = foldl2 extendTCvSubst subst tvs tys - -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst --- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) - && not (cenv1 `intersectsVarEnv` cenv2) ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst -zipTvSubst tvs tys - = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv - where - tenv = zipTyEnv tvs tys - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No TyVars, please! -zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst -zipCvSubst cvs cos - = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv - where - cenv = zipCoEnv cvs cos - -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst -zipTCvSubst tcvs tys - = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) - where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst - zip_tcvsubst (tv:tvs) (ty:tys) subst - = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) - zip_tcvsubst [] [] subst = subst -- empty case - zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" - (ppr tcvs <+> ppr tys) - --- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs prs = - ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) - mkTvSubst in_scope tenv - where tenv = mkVarEnv prs - in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs - onlyTyVarsAndNoCoercionTy = - and [ isTyVar tv && not (isCoercionTy ty) - | (tv, ty) <- prs ] - -zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv -zipTyEnv tyvars tys - | debugIsOn - , not (all isTyVar tyvars) - = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) - | otherwise - = ASSERT( all (not . isCoercionTy) tys ) - mkVarEnv (zipEqual "zipTyEnv" tyvars tys) - -- There used to be a special case for when - -- ty == TyVarTy tv - -- (a not-uncommon case) in which case the substitution was dropped. - -- But the type-tidier changes the print-name of a type variable without - -- changing the unique, and that led to a bug. Why? Pre-tidying, we had - -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. - -- And it happened that t was the type variable of the class. Post-tiding, - -- it got turned into {Foo t2}. The ext-core printer expanded this using - -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, - -- and so generated a rep type mentioning t not t2. - -- - -- Simplest fix is to nuke the "optimisation" - -zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv -zipCoEnv cvs cos - | debugIsOn - , not (all isCoVar cvs) - = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) - | otherwise - = mkVarEnv (zipEqual "zipCoEnv" cvs cos) - -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] - -{- -%************************************************************************ -%* * - Performing type or kind substitutions -%* * -%************************************************************************ - -Note [Sym and ForAllCo] -~~~~~~~~~~~~~~~~~~~~~~~ -In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, -how do we push sym into a ForAllCo? It's a little ugly. - -Here is the typing rule: - -h : k1 ~# k2 -(tv : k1) |- g : ty1 ~# ty2 ----------------------------- -ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# - (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) - -Here is what we want: - -ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# - (ForAllTy (tv : k1) ty1) - - -Because the kinds of the type variables to the right of the colon are the kinds -coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). - -Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want - -ForAllCo tv h' g' : - (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# - (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) - -We thus see that we want - -g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] - -and thus g' = sym (g[tv |-> tv |> h']). - -Putting it all together, we get this: - -sym (ForAllCo tv h g) -==> -ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) - -Note [Substituting in a coercion hole] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It seems highly suspicious to be substituting in a coercion that still -has coercion holes. Yet, this can happen in a situation like this: - - f :: forall k. k :~: Type -> () - f Refl = let x :: forall (a :: k). [a] -> ... - x = ... - -When we check x's type signature, we require that k ~ Type. We indeed -know this due to the Refl pattern match, but the eager unifier can't -make use of givens. So, when we're done looking at x's type, a coercion -hole will remain. Then, when we're checking x's definition, we skolemise -x's type (in order to, e.g., bring the scoped type variable `a` into scope). -This requires performing a substitution for the fresh skolem variables. - -This subsitution needs to affect the kind of the coercion hole, too -- -otherwise, the kind will have an out-of-scope variable in it. More problematically -in practice (we won't actually notice the out-of-scope variable ever), skolems -in the kind might have too high a level, triggering a failure to uphold the -invariant that no free variables in a type have a higher level than the -ambient level in the type checker. In the event of having free variables in the -hole's kind, I'm pretty sure we'll always have an erroneous program, so we -don't need to worry what will happen when the hole gets filled in. After all, -a hole relating a locally-bound type variable will be unable to be solved. This -is why it's OK not to look through the IORef of a coercion hole during -substitution. - --} - --- | Type substitution, see 'zipTvSubst' -substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type --- Works only if the domain of the substitution is a --- superset of the type being substituted into -substTyWith tvs tys = {-#SCC "substTyWith" #-} - ASSERT( tvs `equalLength` tys ) - substTy (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type -substTyWithUnchecked tvs tys - = ASSERT( tvs `equalLength` tys ) - substTyUnchecked (zipTvSubst tvs tys) - --- | Substitute tyvars within a type using a known 'InScopeSet'. --- Pre-condition: the 'in_scope' set should satisfy Note [The substitution --- invariant]; specifically it should include the free vars of 'tys', --- and of 'ty' minus the domain of the subst. -substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type -substTyWithInScope in_scope tvs tys ty = - ASSERT( tvs `equalLength` tys ) - substTy (mkTvSubst in_scope tenv) ty - where tenv = zipTyEnv tvs tys - --- | Coercion substitution, see 'zipTvSubst' -substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion -substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) - substCo (zipTvSubst tvs tys) - --- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithUnchecked tvs tys - = ASSERT( tvs `equalLength` tys ) - substCoUnchecked (zipTvSubst tvs tys) - - - --- | Substitute covars within a type -substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type -substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) - --- | Type substitution, see 'zipTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) - substTys (zipTvSubst tvs tys) - --- | Type substitution, see 'zipTvSubst' -substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] -substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) - substTys (zipCvSubst cvs cos) - --- | Substitute within a 'Type' after adding the free variables of the type --- to the in-scope set. This is useful for the case when the free variables --- aren't already in the in-scope set or easily available. --- See also Note [The substitution invariant]. -substTyAddInScope :: TCvSubst -> Type -> Type -substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty - --- | When calling `substTy` it should be the case that the in-scope set in --- the substitution is a superset of the free vars of the range of the --- substitution. --- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = - (tenvFVs `varSetInScope` in_scope) && - (cenvFVs `varSetInScope` in_scope) - where - tenvFVs = tyCoVarsOfTypesSet tenv - cenvFVs = tyCoVarsOfCosSet cenv - --- | This checks if the substitution satisfies the invariant from --- Note [The substitution invariant]. -checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a - = ASSERT2( isValidTCvSubst subst, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$ - text "cenv" <+> ppr cenv $$ - text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos ) - ASSERT2( tysCosFVsInScope, - text "in_scope" <+> ppr in_scope $$ - text "tenv" <+> ppr tenv $$ - text "cenv" <+> ppr cenv $$ - text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos $$ - text "needInScope" <+> ppr needInScope ) - a - where - substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv - -- It's OK to use nonDetKeysUFM here, because we only use this list to - -- remove some elements from a set - needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) - `delListFromUniqSet_Directly` substDomain - tysCosFVsInScope = needInScope `varSetInScope` in_scope - - --- | Substitute within a 'Type' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTy :: HasCallStack => TCvSubst -> Type -> Type -substTy subst ty - | isEmptyTCvSubst subst = ty - | otherwise = checkValidSubst subst [ty] [] $ - subst_ty subst ty - --- | Substitute within a 'Type' disabling the sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type -substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty - | otherwise = subst_ty subst ty - --- | Substitute within several 'Type's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] -substTys subst tys - | isEmptyTCvSubst subst = tys - | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) 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]. --- The goal of #11371 is to migrate all the calls of substTysUnchecked to --- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] -substTysUnchecked subst tys - | isEmptyTCvSubst subst = tys - | otherwise = map (subst_ty subst) tys - --- | Substitute within a 'ThetaType' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType -substTheta = substTys - --- | Substitute within a 'ThetaType' disabling the sanity checks. --- The problems that the sanity checks in substTys catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substThetaUnchecked to --- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType -substThetaUnchecked = substTysUnchecked - - -subst_ty :: TCvSubst -> Type -> Type --- subst_ty is the main workhorse for type substitution --- --- Note that the in_scope set is poked only if we hit a forall --- so it may often never be fully computed -subst_ty subst ty - = go ty - where - go (TyVarTy tv) = substTyVar subst tv - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- 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 - !res' = go res - in ty { ft_arg = arg', ft_res = res' } - go (ForAllTy (Bndr tv vis) ty) - = case substVarBndrUnchecked subst tv of - (subst', tv') -> - (ForAllTy $! ((Bndr $! tv') vis)) $! - (subst_ty subst' ty) - go (LitTy n) = LitTy $! n - go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) - go (CoercionTy co) = CoercionTy $! (subst_co subst co) - -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - case lookupVarEnv tenv tv of - Just ty -> ty - Nothing -> TyVarTy tv - -substTyVars :: TCvSubst -> [TyVar] -> [Type] -substTyVars subst = map $ substTyVar subst - -substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] -substTyCoVars subst = map $ substTyCoVar subst - -substTyCoVar :: TCvSubst -> TyCoVar -> Type -substTyCoVar subst tv - | isTyVar tv = substTyVar subst tv - | otherwise = CoercionTy $ substCoVar subst tv - -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubst] -lookupTyVar (TCvSubst _ tenv _) tv - = ASSERT( isTyVar tv ) - lookupVarEnv tenv tv - --- | Substitute within a 'Coercion' --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion -substCo subst co - | isEmptyTCvSubst subst = co - | otherwise = checkValidSubst subst [] [co] $ subst_co subst co - --- | Substitute within a 'Coercion' disabling sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion -substCoUnchecked subst co - | isEmptyTCvSubst subst = co - | otherwise = subst_co subst co - --- | Substitute within several 'Coercion's --- The substitution has to satisfy the invariants described in --- Note [The substitution invariant]. -substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] -substCos subst cos - | isEmptyTCvSubst subst = cos - | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos - -subst_co :: TCvSubst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = subst_ty subst - - go_mco :: MCoercion -> MCoercion - go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) - - go :: Coercion -> Coercion - go (Refl ty) = mkNomReflCo $! (go_ty ty) - go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) - go (TyConAppCo r tc args)= let args' = map go args - in args' `seqList` mkTyConAppCo r tc args' - go (AppCo co arg) = (mkAppCo $! go co) $! go arg - go (ForAllCo tv kind_co 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 (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) $! - (go_ty t1)) $! (go_ty t2) - go (SymCo co) = mkSymCo $! (go co) - go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (NthCo r d co) = mkNthCo r d $! (go co) - go (LRCo lr co) = mkLRCo lr $! (go co) - go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg - go (KindCo co) = mkKindCo $! (go co) - go (SubCo co) = mkSubCo $! (go co) - go (AxiomRuleCo c cs) = let cs1 = map go cs - in cs1 `seqList` AxiomRuleCo c cs1 - go (HoleCo h) = HoleCo $! go_hole h - - go_prov UnsafeCoerceProv = UnsafeCoerceProv - go_prov (PhantomProv kco) = PhantomProv (go kco) - go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) - go_prov p@(PluginProv _) = p - - -- See Note [Substituting in a coercion hole] - go_hole h@(CoercionHole { ch_co_var = cv }) - = h { ch_co_var = updateVarType go_ty cv } - -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) -substForAllCoBndr subst - = substForAllCoBndrUsing False (substCo subst) subst - --- | Like 'substForAllCoBndr', but disables sanity checks. --- The problems that the sanity checks in substCo catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substCoUnchecked to --- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) -substForAllCoBndrUnchecked subst - = substForAllCoBndrUsing False (substCoUnchecked subst) subst - --- See Note [Sym and ForAllCo] -substForAllCoBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, KindCoercion) -substForAllCoBndrUsing sym sco subst old_var - | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var - | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var - -substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> KindCoercion - -> (TCvSubst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co - = ASSERT( isTyVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv - , new_var, new_kind_co ) - where - new_env | no_change && not sym = delVarEnv tenv old_var - | sym = extendVarEnv tenv old_var $ - TyVarTy new_var `CastTy` new_kind_co - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - Pair new_ki1 _ = coercionKind new_kind_co - -- We could do substitution to (tyVarKind old_var). We don't do so because - -- we already substituted new_kind_co, which contains the kind information - -- we want. We don't want to do substitution once more. Also, in most cases, - -- new_kind_co is a Refl, in which case coercionKind is really fast. - - new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) - -substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> CoVar -> KindCoercion - -> (TCvSubst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) - old_var old_kind_co - = ASSERT( isCoVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv - , new_var, new_kind_co ) - where - new_cenv | no_change && not sym = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) - - no_kind_change = noFreeVarsOfCo old_kind_co - no_change = no_kind_change && (new_var == old_var) - - new_kind_co | no_kind_change = old_kind_co - | otherwise = sco old_kind_co - - Pair h1 h2 = coercionKind new_kind_co - - new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type - new_var_type | sym = h2 - | otherwise = h1 - -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv - = case lookupVarEnv cenv cv of - Just co -> co - Nothing -> CoVarCo cv - -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] -substCoVars subst cvs = map (substCoVar subst) cvs - -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v - -substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndr = substTyVarBndrUsing substTy - -substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) -substTyVarBndrs = mapAccumL substTyVarBndr - -substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndr = substVarBndrUsing substTy - -substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) -substVarBndrs = mapAccumL substVarBndr - -substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndr = substCoVarBndrUsing substTy - --- | Like 'substVarBndr', but disables sanity checks. --- The problems that the sanity checks in substTy catch are described in --- Note [The substitution invariant]. --- The goal of #11371 is to migrate all the calls of substTyUnchecked to --- substTy and remove this function. Please don't use in new code. -substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndrUnchecked = substVarBndrUsing substTyUnchecked - -substVarBndrUsing :: (TCvSubst -> Type -> Type) - -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) -substVarBndrUsing subst_fn subst v - | isTyVar v = substTyVarBndrUsing subst_fn subst v - | otherwise = substCoVarBndrUsing subst_fn subst v - --- | Substitute a tyvar in a binding position, returning an --- extended subst and a new tyvar. --- Use the supplied function to substitute in the kind -substTyVarBndrUsing - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) - ASSERT( isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) - where - new_env | no_change = delVarEnv tenv old_var - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv) - -- Assertion check that we are not capturing something in the substitution - - old_ki = tyVarKind old_var - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - no_change = no_kind_change && (new_var == old_var) - -- no_change means that the new_var is identical in - -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubst] - -- - -- In that case we don't need to extend the substitution - -- to map old to new. But instead we must zap any - -- current substitution for the variable. For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - - new_var | no_kind_change = uniqAway in_scope old_var - | otherwise = uniqAway in_scope $ - setTyVarKind old_var (subst_fn subst old_ki) - -- The uniqAway part makes sure the new variable is not already in scope - --- | Substitute a covar in a binding position, returning an --- extended subst and a new covar. --- Use the supplied function to substitute in the kind -substCoVarBndrUsing - :: (TCvSubst -> Type -> Type) - -> TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT( isCoVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) - where - new_co = mkCoVarCo new_var - no_kind_change = noFreeVarsOfTypes [t1, t2] - no_change = new_var == old_var && no_kind_change - - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var new_co - - new_var = uniqAway in_scope subst_old_var - subst_old_var = mkCoVar (varName old_var) new_var_type - - (_, _, t1, t2, role) = coVarKindsTypesRole old_var - t1' = subst_fn subst t1 - t2' = subst_fn subst t2 - new_var_type = mkCoercionType role t1' t2' - -- It's important to do the substitution for coercions, - -- because they can have free type variables - -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq - = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') - where - old_ki = tyVarKind tv - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed - - tv1 | no_kind_change = tv - | otherwise = setTyVarKind tv (substTy subst old_ki) - - tv' = setVarUnique tv1 uniq - -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) -cloneTyVarBndrs subst [] _usupply = (subst, []) -cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) - where - (uniq, usupply') = takeUniqFromSupply usupply - (subst' , tv ) = cloneTyVarBndr subst t uniq - (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' - -{- -%************************************************************************ -%* * - Pretty-printing types - - Defined very early because of debug printing in assertions -%* * -%************************************************************************ - -@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is -defined to use this. @pprParendType@ is the same, except it puts -parens around the type, except for the atomic cases. @pprParendType@ -works just by setting the initial context precedence very high. - -Note that any function which pretty-prints a @Type@ first converts the @Type@ -to an @IfaceType@. See Note [IfaceType and pretty-printing] in IfaceType. - -See Note [Precedence in types] in BasicTypes. --} - --------------------------------------------------------- --- When pretty-printing types, we convert to IfaceType, --- and pretty-print that. --- See Note [Pretty printing via IfaceSyn] in PprTyThing --------------------------------------------------------- - -pprType, pprParendType :: Type -> SDoc -pprType = pprPrecType topPrec -pprParendType = pprPrecType appPrec - -pprPrecType :: PprPrec -> Type -> SDoc -pprPrecType = pprPrecTypeX emptyTidyEnv - -pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc -pprPrecTypeX env prec ty - = getPprStyle $ \sty -> - if debugStyle sty -- Use debugPprType when in - then debug_ppr_ty prec ty -- when in debug-style - else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) - -- NB: debug-style is used for -dppr-debug - -- dump-style is used for -ddump-tc-trace etc - -pprTyLit :: TyLit -> SDoc -pprTyLit = pprIfaceTyLit . toIfaceTyLit - -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - -tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType -tidyToIfaceTypeStyX env ty sty - | userStyle sty = tidyToIfaceTypeX env ty - | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty - -- in latter case, don't tidy, as we'll be printing uniques. - -tidyToIfaceType :: Type -> IfaceType -tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv - -tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceTypeX to --- leave them as IfaceFreeTyVar. This is super-important --- for debug printing. -tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) - where - env' = tidyFreeTyCoVars env free_tcvs - free_tcvs = tyCoVarsOfTypeWellScoped ty - ------------- -pprCo, pprParendCo :: Coercion -> SDoc -pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) -pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) - -tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion -tidyToIfaceCoSty co sty - | userStyle sty = tidyToIfaceCo co - | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co - -- in latter case, don't tidy, as we'll be printing uniques. - -tidyToIfaceCo :: Coercion -> IfaceCoercion --- It's vital to tidy before converting to an IfaceType --- or nested binders will become indistinguishable! --- --- Also for the free type variables, tell toIfaceCoercionX to --- leave them as IfaceFreeCoVar. This is super-important --- for debug printing. -tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) - where - env = tidyFreeTyCoVars emptyTidyEnv free_tcvs - free_tcvs = scopedSort $ tyCoVarsOfCoList co ------------- -pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = pprTypeApp (classTyCon clas) tys - ------------- -pprTheta :: ThetaType -> SDoc -pprTheta = pprIfaceContext topPrec . map tidyToIfaceType - -pprParendTheta :: ThetaType -> SDoc -pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType - -pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType - ------------------- -instance Outputable Type where - ppr ty = pprType ty - -instance Outputable TyLit where - ppr = pprTyLit - ------------------- -pprSigmaType :: Type -> SDoc -pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType - -pprForAll :: [TyCoVarBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) - --- | Print a user-level forall; see Note [When to print foralls] -pprUserForAll :: [TyCoVarBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr - -pprTCvBndrs :: [TyCoVarBinder] -> SDoc -pprTCvBndrs tvs = sep (map pprTCvBndr tvs) - -pprTCvBndr :: TyCoVarBinder -> SDoc -pprTCvBndr = pprTyVar . binderVar - -pprTyVars :: [TyVar] -> SDoc -pprTyVars tvs = sep (map pprTyVar tvs) - -pprTyVar :: TyVar -> SDoc --- Print a type variable binder with its kind (but not if *) --- Here we do not go via IfaceType, because the duplication with --- pprIfaceTvBndr is minimal, and the loss of uniques etc in --- debug printing is disastrous -pprTyVar tv - | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) - where - kind = tyVarKind tv - -instance Outputable TyCoBinder where - ppr (Anon af ty) = ppr af <+> ppr ty - ppr (Named (Bndr v Required)) = ppr v - ppr (Named (Bndr v Specified)) = char '@' <> ppr v - ppr (Named (Bndr v Inferred)) = braces (ppr v) - ------------------ -instance Outputable Coercion where -- defined here to avoid orphans - ppr = pprCo - -debugPprType :: Type -> SDoc --- ^ debugPprType is a simple pretty printer that prints a type --- without going through IfaceType. It does not format as prettily --- as the normal route, but it's much more direct, and that can --- be useful for debugging. E.g. with -dppr-debug it prints the --- kind on type-variable /occurrences/ which the normal route --- fundamentally cannot do. -debugPprType ty = debug_ppr_ty topPrec ty - -debug_ppr_ty :: PprPrec -> Type -> SDoc -debug_ppr_ty _ (LitTy l) - = ppr 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 }) - = maybeParen prec funPrec $ - sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] - where - arrow = case af of - VisArg -> text "->" - InvisArg -> text "=>" - -debug_ppr_ty prec (TyConApp tc tys) - | null tys = ppr tc - | otherwise = maybeParen prec appPrec $ - hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) - -debug_ppr_ty _ (AppTy t1 t2) - = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) - 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish - -- TyConApp from AppTy - -debug_ppr_ty prec (CastTy ty co) - = maybeParen prec topPrec $ - hang (debug_ppr_ty topPrec ty) - 2 (text "|>" <+> ppr co) - -debug_ppr_ty _ (CoercionTy co) - = parens (text "CO" <+> ppr co) - -debug_ppr_ty prec ty@(ForAllTy {}) - | (tvs, body) <- split ty - = maybeParen prec funPrec $ - hang (text "forall" <+> fsep (map ppr tvs) <> dot) - -- The (map ppr tvs) will print kind-annotated - -- tvs, because we are (usually) in debug-style - 2 (ppr body) - where - split ty | ForAllTy tv ty' <- ty - , (tvs, body) <- split ty' - = (tv:tvs, body) - | otherwise - = ([], ty) - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we want to print top-level foralls when (and only when) the user specifies --fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses -too much information; see #9018. - -So I'm trying out this rule: print explicit foralls if - a) User specifies -fprint-explicit-foralls, or - b) Any of the quantified type variables has a kind - that mentions a kind variable - -This catches common situations, such as a type siguature - f :: m a -which means - f :: forall k. forall (m :: k->*) (a :: k). m a -We really want to see both the "forall k" and the kind signatures -on m and a. The latter comes from pprTCvBndr. - -Note [Infix type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With TypeOperators you can say - - f :: (a ~> b) -> b - -and the (~>) is considered a type variable. However, the type -pretty-printer in this module will just see (a ~> b) as - - App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") - -So it'll print the type in prefix form. To avoid confusion we must -remember to parenthesise the operator, thus - - (~>) a b -> b - -See #2766. --} - -pprDataCons :: TyCon -> SDoc -pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons - where - sepWithVBars [] = empty - sepWithVBars docs = sep (punctuate (space <> vbar) docs) - -pprDataConWithArgs :: DataCon -> SDoc -pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] - where - (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - user_bndrs = dataConUserTyVarBinders dc - forAllDoc = pprUserForAll user_bndrs - thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) - - -pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys - = pprIfaceTypeApp topPrec (toIfaceTyCon tc) - (toIfaceTcArgs tc tys) - -- TODO: toIfaceTcArgs seems rather wasteful here - ------------------- --- | Display all kind information (with @-fprint-explicit-kinds@) when the --- provided 'Bool' argument is 'True'. --- See @Note [Kind arguments in error messages]@ in "TcErrors". -pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc -pprWithExplicitKindsWhen b - = updSDocDynFlags $ \dflags -> - if b then gopt_set dflags Opt_PrintExplicitKinds - else dflags - -{- -%************************************************************************ -%* * -\subsection{TidyType} -%* * -%************************************************************************ --} - --- | This tidies up a type for printing in an error message, or in --- an interface file. --- --- It doesn't change the uniques at all, just the print names. -tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyVarBndrs tidy_env tvs - = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs - -tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -tidyVarBndr tidy_env@(occ_env, subst) var - = case tidyOccName occ_env (getHelpfulOccName var) of - (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) - name' = tidyNameOcc name occ' - name = varName var - -avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv --- Seed the occ_env with clashes among the names, see --- Note [Tidying multiple names at once] in OccName -avoidNameClashes tvs (occ_env, subst) - = (avoidClashesOccEnv occ_env occs, subst) - where - occs = map getHelpfulOccName tvs - -getHelpfulOccName :: TyCoVar -> OccName --- A TcTyVar with a System Name is probably a --- unification variable; when we tidy them we give them a trailing --- "0" (or 1 etc) so that they don't take precedence for the --- un-modified name. Plus, indicating a unification variable in --- this way is a helpful clue for users -getHelpfulOccName tv - | isSystemName name, isTcTyVar tv - = mkTyVarOcc (occNameString occ ++ "0") - | otherwise - = occ - where - name = varName tv - occ = getOccName name - -tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis - -> (TidyEnv, VarBndr TyCoVar vis) -tidyTyCoVarBinder tidy_env (Bndr tv vis) - = (tidy_env', Bndr tv' vis) - where - (tidy_env', tv') = tidyVarBndr tidy_env tv - -tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] - -> (TidyEnv, [VarBndr TyCoVar vis]) -tidyTyCoVarBinders tidy_env tvbs - = mapAccumL tidyTyCoVarBinder - (avoidNameClashes (binderVars tvbs) tidy_env) tvbs - ---------------- -tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyCoVars (full_occ_env, var_env) tyvars - = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) - ---------------- -tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars - ---------------- -tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) --- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyVarBndr' -tidyOpenTyCoVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> - let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) - in tidyVarBndr env' tyvar -- Treat it as a binder - ---------------- -tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar -tidyTyCoVarOcc env@(_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> updateVarType (tidyType env) tv - Just tv' -> tv' - ---------------- -tidyTypes :: TidyEnv -> [Type] -> [Type] -tidyTypes env tys = map (tidyType env) tys - ---------------- -tidyType :: TidyEnv -> Type -> Type -tidyType _ (LitTy n) = LitTy n -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@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty - where - (tvs, vis, body_ty) = splitForAllTys' ty - (env', tvs') = tidyVarBndrs env tvs -tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) -tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) - - --- The following two functions differ from mkForAllTys and splitForAllTys in that --- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but --- how should they be named? -mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type -mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs - where - strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty - -splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) -splitForAllTys' ty = go ty [] [] - where - go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) - go ty tvs viss = (reverse tvs, reverse viss, ty) - - ---------------- --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys - = (env', tidyTypes (trimmed_occ_env, var_env) tys) - where - (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ - tyCoVarsOfTypesWellScoped tys - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the types, so that we don't gratuitously rename - -- the _bound_ variables of the types. - ---------------- -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in - (env', ty') - ---------------- --- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty - ---------------- -tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyOpenKind = tidyOpenType - -tidyKind :: TidyEnv -> Kind -> Kind -tidyKind = tidyType - ----------------- -tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co - where - go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) - - go (Refl ty) = Refl (tidyType env ty) - go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco - go (TyConAppCo r tc cos) = let args = map go cos - in args `seqList` TyConAppCo r tc args - go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp 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 (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (HoleCo h) = HoleCo h - go (AxiomInstCo con ind cos) = let args = map go cos - in args `seqList` AxiomInstCo con ind args - go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! - tidyType env t1) $! tidyType env t2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo r d co) = NthCo r d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! go ty - go (KindCo co) = KindCo $! go co - go (SubCo co) = SubCo $! go co - go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos - in cos1 `seqList` AxiomRuleCo ax cos1 - - go_prov UnsafeCoerceProv = UnsafeCoerceProv - go_prov (PhantomProv co) = PhantomProv (go co) - go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) - go_prov p@(PluginProv _) = p - -tidyCos :: TidyEnv -> [Coercion] -> [Coercion] -tidyCos env = map (tidyCo env) + TyCoPpr imports TyCoRep + TyCoFVs imports TyCoRep + TyCoSubst imports TyCoRep, TyCoFVs, TyCoPpr + TyCoTidy imports TyCoRep, TyCoFVs + TysPrim imports TyCoRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} + +module TyCoRep ( + TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, + + -- * Types + Type( TyVarTy, AppTy, TyConApp, ForAllTy + , LitTy, CastTy, CoercionTy + , FunTy, ft_arg, ft_res, ft_af + ), -- Export the type synonym FunTy too + + TyLit(..), + KindOrType, Kind, + KnotTied, + PredType, ThetaType, -- Synonyms + ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + + -- * Coercions + Coercion(..), + UnivCoProvenance(..), + CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + CoercionN, CoercionR, CoercionP, KindCoercion, + MCoercion(..), MCoercionR, MCoercionN, + + -- * Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + mkForAllTy, mkForAllTys, + mkPiTy, mkPiTys, + + kindRep_maybe, kindRep, + isLiftedTypeKind, isUnliftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, + isRuntimeRepTy, isRuntimeRepVar, + sameVis, + + -- * Functions over binders + TyCoBinder(..), TyCoVarBinder, TyBinder, + binderVar, binderVars, binderType, binderArgFlag, + delBinderVar, + isInvisibleArgFlag, isVisibleArgFlag, + isInvisibleBinder, isVisibleBinder, + isTyBinder, isNamedBinder, + + -- * Functions over coercions + pickLR, + + -- * Sizes + typeSize, coercionSize, provSize + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} Type( coreView ) +import {-# SOURCE #-} TyCoPpr ( pprType, pprCo, pprTyLit ) + + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) + +-- friends: +import IfaceType +import Var +import VarSet +import Name hiding ( varName ) +import TyCon +import CoAxiom + +-- others +import BasicTypes ( LeftOrRight(..), pickLR ) +import PrelNames +import Outputable +import FastString +import Util + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +It is also SOURCE-imported into Name.hs + + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See 'TcEnv' for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +pprShortTyThing :: TyThing -> SDoc +-- c.f. PprTyThing.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" + + +{- ********************************************************************** +* * + Type +* * +********************************************************************** -} + +-- | The key representation of types within the compiler + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', + -- must be another 'AppTy', or 'TyVarTy' + -- See Note [Respecting definitional equality] (EQ1) about the + -- no 'CastTy' requirement + -- + -- 2) Argument type + + | TyConApp + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy + {-# UNPACK #-} !TyCoVarBinder + Type -- ^ A Π type. + + | FunTy -- ^ t1 -> t2 Very common, so an important special case + -- See Note [Function types] + { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + KindCoercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never refl. + -- INVARIANT: The Type is not a CastTy (use TransCo instead) + -- See Note [Respecting definitional equality] (EQ2) and (EQ3) + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving Data.Data + +instance Outputable Type where + ppr = pprType + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data) + +instance Outputable TyLit where + ppr = pprTyLit + +{- Note [Function types] +~~~~~~~~~~~~~~~~~~~~~~~~ +FFunTy is the constructor for a function type. Lots of things to say +about it! + +* FFunTy is the data constructor, meaning "full function type". + +* The function type constructor (->) has kind + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep + mkTyConApp ensure that we convert a saturated application + TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 + dropping the 'r1' and 'r2' arguments; they are easily recovered + from 't1' and 't2'. + +* The ft_af field says whether or not this is an invisible argument + VisArg: t1 -> t2 Ordinary function type + InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, + i.e. t1 :: Constraint + See Note [Types for coercions, predicates, and evidence] + + This visibility info makes no difference in Core; it matters + only when we regard the type as a Haskell source type. + +* FunTy is a (unidirectional) pattern synonym that allows + positional pattern matching (FunTy arg res), ignoring the + ArgFlag. +-} + +{- ----------------------- + Commented out until the pattern match + checker can handle it; see #16185 + + For now we use the CPP macro #define FunTy FFunTy _ + (see HsVersions.h) to allow pattern matching on a + (positional) FunTy constructor. + +{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp + , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} + +-- | 'FunTy' is a (uni-directional) pattern synonym for the common +-- case where we want to match on the argument/result type, but +-- ignoring the AnonArgFlag +pattern FunTy :: Type -> Type -> Type +pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } + + End of commented out block +---------------------------------- -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat differently: + + (a) Predicate types + Test: isPredTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) Coercion types are primitive, unboxed equalities + Test: isCoVarTy + Binders: CoVars (can appear in coercions) + Kind: TYPE (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) Evidence types is the type of evidence manipulated by + the type constraint solver. + Test: isEvVarType + Binders: EvVars + Kind: Constraint or TYPE (TupleRep []) + Examples: all coercion types and predicate types + +Coercion types and predicate types are mutually exclusive, +but evidence types are a superset of both. + +When treated as a user type, + + - Predicates (of kind Constraint) are invisible and are + implicitly instantiated + + - Coercion types, and non-pred evidence types (i.e. not + of kind Constrain), are just regular old types, are + visible, and are not implicitly instantiated. + +In a FunTy { ft_af = InvisArg }, the argument type is always +a Predicate type. + +Note [Constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do we allow a type constructor to have a kind like + S :: Eq a => a -> Type + +No, we do not. Doing so would mean would need a TyConApp like + S @k @(d :: Eq k) (ty :: k) + and we have no way to build, or decompose, evidence like + (d :: Eq k) at the type level. + +But we admit one exception: equality. We /do/ allow, say, + MkT :: (a ~ b) => a -> b -> Type a b + +Why? Because we can, without much difficulty. Moreover +we can promote a GADT data constructor (see TyCon +Note [Promoted data constructors]), like + data GT a b where + MkGT : a -> a -> GT a a +so programmers might reasonably expect to be able to +promote MkT as well. + +How does this work? + +* In TcValidity.checkConstraintsOK we reject kinds that + have constraints other than (a~b) and (a~~b). + +* In Inst.tcInstInvisibleTyBinder we instantiate a call + of MkT by emitting + [W] co :: alpha ~# beta + and producing the elaborated term + MkT @alpha @beta (Eq# alpha beta co) + We don't generate a boxed "Wanted"; we generate only a + regular old /unboxed/ primitive-equality Wanted, and build + the box on the spot. + +* How can we get such a MkT? By promoting a GADT-style data + constructor + data T a b where + MkT :: (a~b) => a -> b -> T a b + See DataCon.mkPromotedDataCon + and Note [Promoted data constructors] in TyCon + +* We support both homogeneous (~) and heterogeneous (~~) + equality. (See Note [The equality types story] + in TysPrim for a primer on these equality types.) + +* How do we prevent a MkT having an illegal constraint like + Eq a? We check for this at use-sites; see TcHsType.tcTyVar, + specifically dc_theta_illegal_constraint. + +* Notice that nothing special happens if + K :: (a ~# b) => blah + because (a ~# b) is not a predicate type, and is never + implicitly instantiated. (Mind you, it's not clear how you + could creates a type constructor with such a kind.) See + Note [Types for coercions, predicates, and evidence] + +* The existence of promoted MkT with an equality-constraint + argument is the (only) reason that the AnonTCB constructor + of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + For example, when we promote the data constructor + MkT :: forall a b. (a~b) => a -> b -> T a b + we get a PromotedDataCon with tyConBinders + Bndr (a :: Type) (NamedTCB Inferred) + Bndr (b :: Type) (NamedTCB Inferred) + Bndr (_ :: a ~ b) (AnonTCB InvisArg) + Bndr (_ :: a) (AnonTCB VisArg)) + Bndr (_ :: b) (AnonTCB VisArg)) + +* One might reasonably wonder who *unpacks* these boxes once they are + made. After all, there is no type-level `case` construct. The + surprising answer is that no one ever does. Instead, if a GADT + constructor is used on the left-hand side of a type family equation, + that occurrence forces GHC to unify the types in question. For + example: + + data G a where + MkG :: G Bool + + type family F (x :: G a) :: a where + F MkG = False + + When checking the LHS `F MkG`, GHC sees the MkG constructor and then must + unify F's implicit parameter `a` with Bool. This succeeds, making the equation + + F Bool (MkG @Bool ) = False + + Note that we never need unpack the coercion. This is because type + family equations are *not* parametric in their kind variables. That + is, we could have just said + + type family H (x :: G a) :: a where + H _ = False + + The presence of False on the RHS also forces `a` to become Bool, + giving us + + H Bool _ = False + + The fact that any of this works stems from the lack of phase + separation between types and kinds (unlike the very present phase + separation between terms and types). + + Once we have the ability to pattern-match on types below top-level, + this will no longer cut it, but it seems fine for now. + + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is Int |> <*> the same as Int? YES! In order to reduce headaches, +we decide that any reflexive casts in types are just ignored. +(Indeed they must be. See Note [Respecting definitional equality].) +More generally, the `eqType` function, which defines Core's type equality +relation, ignores casts and coercion arguments, as long as the +two types have the same kind. This allows us to be a little sloppier +in keeping track of coercions, which is a good thing. It also means +that eqType does not depend on eqCoercion, which is also a good thing. + +Why is this sensible? That is, why is something different than α-equivalence +appropriate for the implementation of eqType? + +Anything smaller than ~ and homogeneous is an appropriate definition for +equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any +expression of type τ can be transmuted to one of type σ at any point by +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. + +But let's be more precise. If we examine the typing rules of FC (say, those in +https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) +there are several places where the same metavariable is used in two different +premises to a rule. (For example, see Ty_App.) There is an implicit equality +check here. What definition of equality should we use? By convention, we use +α-equivalence. Take any rule with one (or more) of these implicit equality +checks. Then there is an admissible rule that uses ~ instead of the implicit +check, adding in casts as appropriate. + +The only problem here is that ~ is heterogeneous. To make the kinds work out +in the admissible rule that uses ~, it is necessary to homogenize the +coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; +we use η |> kind η, which is homogeneous. + +The effect of this all is that eqType, the implementation of the implicit +equality check, can use any homogeneous relation that is smaller than ~, as +those rules must also be admissible. + +A more drawn out argument around all of this is presented in Section 7.2 of +Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). + +What would go wrong if we insisted on the casts matching? See the beginning of +Section 8 in the unpublished paper above. Theoretically, nothing at all goes +wrong. But in practical terms, getting the coercions right proved to be +nightmarish. And types would explode: during kind-checking, we often produce +reflexive kind coercions. When we try to cast by these, mkCastTy just discards +them. But if we used an eqType that distinguished between Int and Int |> <*>, +then we couldn't discard -- the output of kind-checking would be enormous, +and we would need enormous casts with lots of CoherenceCo's to straighten +them out. + +Would anything go wrong if eqType respected type families? No, not at all. But +that makes eqType rather hard to implement. + +Thus, the guideline for eqType is that it should be the largest +easy-to-implement relation that is still smaller than ~ and homogeneous. The +precise choice of relation is somewhat incidental, as long as the smart +constructors and destructors in Type respect whatever relation is chosen. + +Another helpful principle with eqType is this: + + (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. + +This principle also tells us that eqType must relate only types with the +same kinds. + +Note [Respecting definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Non-trivial definitional equality] introduces the property (EQ). +How is this upheld? + +Any function that pattern matches on all the constructors will have to +consider the possibility of CastTy. Presumably, those functions will handle +CastTy appropriately and we'll be OK. + +More dangerous are the splitXXX functions. Let's focus on splitTyConApp. +We don't want it to fail on (T a b c |> co). Happily, if we have + (T a b c |> co) `eqType` (T d e f) +then co must be reflexive. Why? eqType checks that the kinds are equal, as +well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). +By the kind check, we know that (T a b c |> co) and (T d e f) have the same +kind. So the only way that co could be non-reflexive is for (T a b c) to have +a different kind than (T d e f). But because T's kind is closed (all tycon kinds +are closed), the only way for this to happen is that one of the arguments has +to differ, leading to a contradiction. Thus, co is reflexive. + +Accordingly, by eliminating reflexive casts, splitTyConApp need not worry +about outermost casts to uphold (EQ). Eliminating reflexive casts is done +in mkCastTy. + +Unforunately, that's not the end of the story. Consider comparing + (T a b c) =? (T a b |> (co -> )) (c |> co) +These two types have the same kind (Type), but the left type is a TyConApp +while the right type is not. To handle this case, we say that the right-hand +type is ill-formed, requiring an AppTy never to have a casted TyConApp +on its left. It is easy enough to pull around the coercions to maintain +this invariant, as done in Type.mkAppTy. In the example above, trying to +form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). +Both the casts there are reflexive and will be dropped. Huzzah. + +This idea of pulling coercions to the right works for splitAppTy as well. + +However, there is one hiccup: it's possible that a coercion doesn't relate two +Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, +then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't +be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not +`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate +our (EQ) property. + +Lastly, in order to detect reflexive casts reliably, we must make sure not +to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). + +In sum, in order to uphold (EQ), we need the following three invariants: + + (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable + cast is one that relates either a FunTy to a FunTy or a + ForAllTy to a ForAllTy. + (EQ2) No reflexive casts in CastTy. + (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] in Type. + +These invariants are all documented above, in the declaration for Type. + +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~ t2). e + +What type should we give to this expression? + (1) forall (co:t1 ~ t2) -> t + (2) (t1 ~ t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkLamType, we check whether the variable is a coercion +variable (of type (t1 ~# t2), and whether it is un-used in the +body. If so, it returns a FunTy instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is +unnecessary when it is known from the context that the input variable +is a type variable. In those cases, we use mkForAllTy. + +-} + +-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See +-- Note [Type checking recursive type and class declarations] in +-- TcTyClsDecls +type KnotTied ty = ty + +{- ********************************************************************** +* * + TyCoBinder and ArgFlag +* * +********************************************************************** -} + +-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- 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 + deriving Data.Data + +instance Outputable TyCoBinder where + ppr (Anon af ty) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) + + +-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' +-- in the 'Named' field. +type TyBinder = TyCoBinder + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyCoVarBinder -> VarSet +delBinderVar vars (Bndr tv _) = vars `delVarSet` tv + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyCoBinder -> Bool +isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis +isInvisibleBinder (Anon InvisArg _) = True +isInvisibleBinder (Anon VisArg _) = False + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyCoBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +isNamedBinder :: TyCoBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder (Anon {}) = False + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: TyCoBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +{- Note [TyCoBinders] +~~~~~~~~~~~~~~~~~~~ +A ForAllTy contains a TyCoVarBinder. But a type can be decomposed +to a telescope consisting of a [TyCoBinder] + +A TyCoBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * A non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + + +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. + Each TyCoVarBinder + Bndr a tvis + is equipped with tvis::ArgFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term +| tvis :: ArgFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: T :: forall k -> type Arg required: T * +| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f4 :: a b -> Int + So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f5 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: with -fprint-explicit-foralls, Inferred binders are written + in braces: + f :: forall {k} (a:k). S k a -> Int + Otherwise, they are printed like Specified binders. + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). + +Note [No Required TyCoBinder in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Required foralls for term variables, including pattern +synonyms and data constructors. Why? Because then an application +would need a /compulsory/ type argument (possibly without an "@"?), +thus (f Int); and we don't have concrete syntax for that. + +We could change this decision, but Required, Named TyCoBinders are rare +anyway. (Most are Anons.) + +However the type of a term can (just about) have a required quantifier; +see Note [Required quantifiers in the type of a term] in TcExpr. +-} + + +{- ********************************************************************** +* * + PredType +* * +********************************************************************** -} + + +-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to have +-- this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + +infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } + +mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type +mkVisFunTy = mkFunTy VisArg +mkInvisFunTy = mkFunTy InvisArg + +-- | Make nested arrow types +mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type +mkVisFunTys tys ty = foldr mkVisFunTy ty tys +mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys + +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty + +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +mkPiTy:: TyCoBinder -> Type -> Type +mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } +mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty + +mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +{- +Some basic functions, put here to break loops eg with the pretty printer +-} + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> Type +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +-- Treats * and Constraint as the same +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindRep_maybe kind + | Just kind' <- coreView kind = kindRep_maybe kind' + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +-- | This version considers Constraint to be the same as *. Returns True +-- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +isLiftedRuntimeRep :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeRep rep + | Just rep' <- coreView rep = isLiftedRuntimeRep rep' + | TyConApp rr_tc args <- rep + , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | otherwise = False + +isUnliftedRuntimeRep :: Type -> Bool +-- True of definitely-unlifted RuntimeReps +-- False of (LiftedRep :: RuntimeRep) +-- and of variables (a :: RuntimeRep) +isUnliftedRuntimeRep rep + | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' + | TyConApp rr_tc _ <- rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' +isRuntimeRepTy (TyConApp tc args) + | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True +isRuntimeRepTy _ = False + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. + -- - P, N, and R stand for coercions of the given role + -- - e stands for a coercion of a specific unknown role + -- (think "role polymorphism") + -- - "e" stands for an explicit role parameter indicating role e. + -- - _ stands for a parameter that is not a Role or Coercion. + + -- These ones mirror the shape of types + = -- Refl :: _ -> N + Refl Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) + + -- GRefl :: "e" -> _ -> Maybe N -> e + -- See Note [Generalized reflexive coercion] + | GRefl Role Type MCoercionN -- See Note [Refl invariant] + -- Use (Refl ty), not (GRefl Nominal ty MRefl) + -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + + | AppCo Coercion CoercionN -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyCoVar KindCoercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + | FunCo Role Coercion Coercion -- lift FunTy + -- FunCo :: "e" -> 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 + -- types, and that is irrelevant for coercions, which are + -- Core-only. + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> ?? -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + -- The roles of the argument coercions are determined + -- by the cab_roles field of the relevant branch of the CoAxiom + + | AxiomRuleCo CoAxiomRule [Coercion] + -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + -- + -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) + -- That is: the role of the entire coercion is redundantly cached here. + -- See Note [NthCo Cached Roles] + + | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion CoercionN + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo CoercionN -- Turns a ~N into a ~R + -- :: N -> R + + | HoleCo CoercionHole -- ^ See Note [Coercion holes] + -- Only present during typechecking + deriving Data.Data + +type CoercionN = Coercion -- always nominal +type CoercionR = Coercion -- always representational +type CoercionP = Coercion -- always phantom +type KindCoercion = CoercionN -- always nominal + +instance Outputable Coercion where + ppr = pprCo + +-- | A semantically more meaningful type to represent what may or may not be a +-- useful 'Coercion'. +data MCoercion + = MRefl + -- A trivial Reflexivity coercion + | MCo Coercion + -- Other coercions + deriving Data.Data +type MCoercionR = MCoercion +type MCoercionN = MCoercion + +instance Outputable MCoercion where + ppr MRefl = text "MRefl" + ppr (MCo co) = text "MCo" <+> ppr co + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: + +Coercions have the following invariant + Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. + +You might think that a consequencs is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Generalized reflexive coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GRefl is a generalized reflexive coercion (see #15192). It wraps a kind +coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing +rules for GRefl: + + ty : k1 + ------------------------------------ + GRefl r ty MRefl: ty ~r ty + + ty : k1 co :: k1 ~ k2 + ------------------------------------ + GRefl r ty (MCo co) : ty ~r ty |> co + +Consider we have + + g1 :: s ~r t + s :: k1 + g2 :: k1 ~ k2 + +and we want to construct a coercions co which has type + + (s |> g2) ~r t + +We can define + + co = Sym (GRefl r s g2) ; g1 + +It is easy to see that + + Refl == GRefl Nominal ty MRefl :: ty ~n ty + +A nominal reflexive coercion is quite common, so we keep the special form Refl to +save allocation. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + + kind_co : k1 ~ k2 + tv1:k1 |- co : t1 ~ t2 + ------------------------------------------------------------------- + ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ + all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) + +First, the TyCoVar stored in a ForAllCo is really an optimisation: this field +should be a Name, as its kind is redundant. Thinking of the field as a Name +is helpful in understanding what a ForAllCo means. +The kind of TyCoVar always matches the left-hand kind of the coercion. + +The idea is that kind_co gives the two kinds of the tyvar. See how, in the +conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + +Of course, a type variable can't have different kinds at the same time. So, +we arbitrarily prefer the first kind when using tv1 in the inner coercion +co, which shows that t1 equals t2. + +The last wrinkle is that we need to fix the kinds in the conclusion. In +t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of +the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with +(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it +mentions the same name with different kinds, but it *is* well-kinded, noting +that `(tv1:k2) |> sym kind_co` has kind k1. + +This all really would work storing just a Name in the ForAllCo. But we can't +add Names to, e.g., VarSets, and there generally is just an impedance mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo r 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [NthCo Cached Roles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we cache the role of NthCo in the NthCo constructor? +Because computing role(Nth i co) involves figuring out that + + co :: T tys1 ~ T tys2 + +using coercionKind, and finding (coercionRole co), and then looking +at the tyConRoles of T. Avoiding bad asymptotic behaviour here means +we have to compute the kind and role of a coercion simultaneously, +which makes the code complicated and inefficient. + +This only happens for NthCo. Caching the role solves the problem, and +allows coercionKind and coercionRole to be simple. + +See #11735 + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + + +%************************************************************************ +%* * + UnivCoProvenance +%* * +%************************************************************************ + +A UnivCo is a coercion whose proof does not directly express its role +and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/ +no proof). + +The different kinds of UnivCo are described by UnivCoProvenance. Really +each is entirely separate, but they all share the need to represent their +role and kind, which is done in the UnivCo constructor. + +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. The UnivCoProvenance specifies more exactly what the coercion really +-- is and why a program should (or shouldn't!) trust the coercion. +-- It is reasonable to consider each constructor of 'UnivCoProvenance' +-- as a totally independent coercion form; their only commonality is +-- that they don't tell you what types they coercion between. (That info +-- is in the 'UnivCo' constructor of 'Coercion'. +data UnivCoProvenance + = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. + + | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions + + | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions + + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + + deriving Data.Data + +instance Outputable UnivCoProvenance where + ppr UnsafeCoerceProv = text "(unsafeCoerce#)" + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { ch_co_var :: CoVar + -- See Note [CoercionHoles and coercion free variables] + + , ch_ref :: IORef (Maybe Coercion) + } + +coHoleCoVar :: CoercionHole -> CoVar +coHoleCoVar = ch_co_var + +setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole +setCoHoleCoVar h cv = h { ch_co_var = cv } + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) + + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~ +During typechecking, constraint solving for type classes works by + - Generate an evidence Id, d7 :: Num a + - Wrap it in a Wanted constraint, [W] d7 :: Num a + - Use the evidence Id where the evidence is needed + - Solve the constraint later + - When solved, add an enclosing let-binding let d7 = .... in .... + which actually binds d7 to the (Num a) evidence + +For equality constraints we use a different strategy. See Note [The +equality types story] in TysPrim for background on equality constraints. + - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just + like type classes above. (Indeed, boxed equality constraints *are* classes.) + - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) + we use a different plan + +For unboxed equalities: + - Generate a CoercionHole, a mutable variable just like a unification + variable + - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest + - Use the CoercionHole in a Coercion, via HoleCo + - Solve the constraint later + - When solved, fill in the CoercionHole by side effect, instead of + doing the let-binding thing + +The main reason for all this is that there may be no good place to let-bind +the evidence for unboxed equalities: + + - We emit constraints for kind coercions, to be used to cast a + type's kind. These coercions then must be used in types. Because + they might appear in a top-level type, there is no place to bind + these (unlifted) coercions in the usual way. + + - A coercion for (forall a. t1) ~ (forall a. t2) will look like + forall a. (coercion for t1~t2) + But the coercion for (t1~t2) may mention 'a', and we don't have + let-bindings within coercions. We could add them, but coercion + holes are easier. + + - Moreover, nothing is lost from the lack of let-bindings. For + dicionaries want to achieve sharing to avoid recomoputing the + dictionary. But coercions are entirely erased, so there's little + benefit to sharing. Indeed, even if we had a let-binding, we + always inline types and coercions at every use site and drop the + binding. + +Other notes about HoleCo: + + * INVARIANT: CoercionHole and HoleCo are used only during type checking, + and should never appear in Core. Just like unification variables; a Type + can contain a TcTyVar, but only during type checking. If, one day, we + use type-level information to separate out forms that can appear during + type-checking vs forms that can appear in core proper, holes in Core will + be ruled out. + + * See Note [CoercionHoles and coercion free variables] + + * Coercion holes can be compared for equality like other coercions: + by looking at the types coerced. + + +Note [CoercionHoles and coercion free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does a CoercionHole contain a CoVar, as well as reference to +fill in? Because we want to treat that CoVar as a free variable of +the coercion. See #14584, and Note [What prevents a +constraint from floating] in TcSimplify, item (4): + + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + +Here co2 is a CoercionHole. But we /must/ know that it is free in +co1, because that's all that stops it floating outside the +implication. + + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~ Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) + where + co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) + co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] +-} {- ********************************************************************* diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -2,7 +2,6 @@ import GhcPrelude -import Outputable ( SDoc ) import Data.Data ( Data ) import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) @@ -10,7 +9,6 @@ data TyThing data Coercion data UnivCoProvenance -data TCvSubst data TyLit data TyCoBinder data MCoercion @@ -21,8 +19,6 @@ type CoercionN = Coercion type MCoercionN = MCoercion -pprKind :: Kind -> SDoc -pprType :: Type -> SDoc mkFunTy :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type diff --git a/compiler/types/TyCoSubst.hs b/compiler/types/TyCoSubst.hs new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoSubst.hs @@ -0,0 +1,1029 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +Type and Coercion - friends' interface +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +-- | Substitution into types and coercions. +module TyCoSubst + ( + -- * Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, + getTvSubstEnv, + getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, + isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstWithClone, + extendCvSubst, extendCvSubstWithClone, + extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, + zipTvSubst, zipCvSubst, + zipTCvSubst, + mkTvSubstPrs, + + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyWithInScope, + substTys, substTheta, + lookupTyVar, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, + substTyVar, substTyVars, substTyCoVars, + substForAllCoBndr, + substVarBndrUsing, substForAllCoBndrUsing, + checkValidSubst, isValidTCvSubst, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} Type ( mkCastTy, mkAppTy, isCoercionTy ) +import {-# SOURCE #-} Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo + , mkNomReflCo, mkSubCo, mkSymCo + , mkFunCo, mkForAllCo, mkUnivCo + , mkAxiomInstCo, mkAppCo, mkGReflCo + , mkInstCo, mkLRCo, mkTyConAppCo + , mkCoercionType + , coercionKind, coVarKindsTypesRole ) + +import TyCoRep +import TyCoFVs +import TyCoPpr + +import Var +import VarSet +import VarEnv + +import Pair +import Util +import UniqSupply +import Unique +import UniqFM +import UniqSet +import Outputable + +import Data.List + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion substitution +-- +-- #tcvsubst_invariant# +-- The following invariants must hold of a 'TCvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reach a fixed point. +data TCvSubst + = TCvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + CvSubstEnv -- Substitutes coercion variables + -- See Note [Substitutions apply only once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + -- and Note [The substitution invariant] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- NB: A TvSubstEnv is used + -- both inside a TCvSubst (with the apply-once invariant + -- discussed in Note [Substitutions apply only once], + -- and also independently in the middle of matching, + -- and unification (see Types.Unify). + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- Note [The substitution invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When calling (substTy subst ty) it should be the case that +the in-scope set in the substitution is a superset of both: + + (SIa) The free vars of the range of the substitution + (SIb) The free vars of ty minus the domain of the substitution + +The same rules apply to other substitutions (notably CoreSubst.Subst) + +* Reason for (SIa). Consider + substTy [a :-> Maybe b] (forall b. b->a) + we must rename the forall b, to get + forall b2. b2 -> Maybe b + Making 'b' part of the in-scope set forces this renaming to + take place. + +* Reason for (SIb). Consider + substTy [a :-> Maybe b] (forall b. (a,b,x)) + Then if we use the in-scope set {b}, satisfying (SIa), there is + a danger we will rename the forall'd variable to 'x' by mistake, + getting this: + forall x. (Maybe b, x, x) + Breaking (SIb) caused the bug from #11371. + +Note: if the free vars of the range of the substitution are freshly created, +then the problems of (SIa) can't happen, and so it would be sound to +ignore (SIa). + +Note [Substitutions apply only once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + ******************************************************** + *** So a substitution must be applied precisely once *** + ******************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tcvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +However, the constructor used to create type variables is distinct from +that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note +that it would be possible to use the CoercionTy constructor to combine +these environments, but that seems like a false economy. + +Note that the TvSubstEnv should *never* map a CoVar (built with the Id +constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, +the range of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +composeTCvSubstEnv :: InScopeSet + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) + = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TCvSubst in_scope tenv1 cenv1 + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. +composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) + = TCvSubst is3 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + +emptyTCvSubst :: TCvSubst +emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + +mkEmptyTCvSubst :: InScopeSet -> TCvSubst +mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv + +isEmptyTCvSubst :: TCvSubst -> Bool + -- See Note [Extending the TvSubstEnv] +isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst +mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst +mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv + +mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +-- | Returns the free variables of the types in the range of a substitution as +-- a non-deterministic set. +getTCvSubstRangeFVs :: TCvSubst -> VarSet +getTCvSubstRangeFVs (TCvSubst _ tenv cenv) + = unionVarSet tenvFVs cenvFVs + where + tenvFVs = tyCoVarsOfTypesSet tenv + cenvFVs = tyCoVarsOfCosSet cenv + +isInScope :: Var -> TCvSubst -> Bool +isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope + +notElemTCvSubst :: Var -> TCvSubst -> Bool +notElemTCvSubst v (TCvSubst _ tenv cenv) + | isTyVar v + = not (v `elemVarEnv` tenv) + | otherwise + = not (v `elemVarEnv` cenv) + +setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst +setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + +setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst +setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv + +zapTCvSubst :: TCvSubst -> TCvSubst +zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv + +extendTCvInScope :: TCvSubst -> Var -> TCvSubst +extendTCvInScope (TCvSubst in_scope tenv cenv) var + = TCvSubst (extendInScopeSet in_scope var) tenv cenv + +extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst +extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv + +extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst +extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv + +extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst subst v ty + | isTyVar v + = extendTvSubst subst v ty + | CoercionTy co <- ty + = extendCvSubst subst v co + | otherwise + = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) + +extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + +extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv + +extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty + = ASSERT( isTyVar v ) + extendTvSubstAndInScope subst v ty +extendTvSubstBinderAndInScope subst (Anon {}) _ + = subst + +extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set +extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv + where + new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' + +extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst +extendCvSubst (TCvSubst in_scope tenv cenv) v co + = TCvSubst in_scope tenv (extendVarEnv cenv v co) + +extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst +extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + tenv + (extendVarEnv cenv cv (mkCoVarCo cv')) + where + new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' + +extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + +extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTvSubstList subst tvs tys + = foldl2 extendTvSubst subst tvs tys + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +-- Works when the ranges are disjoint +unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) + && not (cenv1 `intersectsVarEnv` cenv2) ) + TCvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- mkTvSubstPrs and zipTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No CoVars, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst +zipTvSubst tvs tys + = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv + where + tenv = zipTyEnv tvs tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No TyVars, please! +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst cvs cos + = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where + cenv = zipCoEnv cvs cos + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst tcvs tys + = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) + where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the +-- incoming environment. No CoVars, please! +mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst +mkTvSubstPrs prs = + ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) + mkTvSubst in_scope tenv + where tenv = mkVarEnv prs + in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs + onlyTyVarsAndNoCoercionTy = + and [ isTyVar tv && not (isCoercionTy ty) + | (tv, ty) <- prs ] + +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars) + = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) + | otherwise + = ASSERT( all (not . isCoercionTy) tys ) + mkVarEnv (zipEqual "zipTyEnv" tyvars tys) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ text "TCvSubst", + nest 2 (text "In scope:" <+> ppr ins), + nest 2 (text "Type env:" <+> ppr tenv), + nest 2 (text "Co env:" <+> ppr cenv) ] + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Here is the typing rule: + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +Note [Substituting in a coercion hole] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It seems highly suspicious to be substituting in a coercion that still +has coercion holes. Yet, this can happen in a situation like this: + + f :: forall k. k :~: Type -> () + f Refl = let x :: forall (a :: k). [a] -> ... + x = ... + +When we check x's type signature, we require that k ~ Type. We indeed +know this due to the Refl pattern match, but the eager unifier can't +make use of givens. So, when we're done looking at x's type, a coercion +hole will remain. Then, when we're checking x's definition, we skolemise +x's type (in order to, e.g., bring the scoped type variable `a` into scope). +This requires performing a substitution for the fresh skolem variables. + +This subsitution needs to affect the kind of the coercion hole, too -- +otherwise, the kind will have an out-of-scope variable in it. More problematically +in practice (we won't actually notice the out-of-scope variable ever), skolems +in the kind might have too high a level, triggering a failure to uphold the +invariant that no free variables in a type have a higher level than the +ambient level in the type checker. In the event of having free variables in the +hole's kind, I'm pretty sure we'll always have an erroneous program, so we +don't need to worry what will happen when the hole gets filled in. After all, +a hole relating a locally-bound type variable will be unable to be solved. This +is why it's OK not to look through the IORef of a coercion hole during +substitution. + +-} + +-- | Type substitution, see 'zipTvSubst' +substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type +-- Works only if the domain of the substitution is a +-- superset of the type being substituted into +substTyWith tvs tys = {-#SCC "substTyWith" #-} + ASSERT( tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type +substTyWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substTyUnchecked (zipTvSubst tvs tys) + +-- | Substitute tyvars within a type using a known 'InScopeSet'. +-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution +-- invariant]; specifically it should include the free vars of 'tys', +-- and of 'ty' minus the domain of the subst. +substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope in_scope tvs tys ty = + ASSERT( tvs `equalLength` tys ) + substTy (mkTvSubst in_scope tenv) ty + where tenv = zipTyEnv tvs tys + +-- | Coercion substitution, see 'zipTvSubst' +substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) + +-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substCoUnchecked (zipTvSubst tvs tys) + + + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) + +-- | Type substitution, see 'zipTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) + +-- | Substitute within a 'Type' after adding the free variables of the type +-- to the in-scope set. This is useful for the case when the free variables +-- aren't already in the in-scope set or easily available. +-- See also Note [The substitution invariant]. +substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope subst ty = + substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + +-- | When calling `substTy` it should be the case that the in-scope set in +-- the substitution is a superset of the free vars of the range of the +-- substitution. +-- See also Note [The substitution invariant]. +isValidTCvSubst :: TCvSubst -> Bool +isValidTCvSubst (TCvSubst in_scope tenv cenv) = + (tenvFVs `varSetInScope` in_scope) && + (cenvFVs `varSetInScope` in_scope) + where + tenvFVs = tyCoVarsOfTypesSet tenv + cenvFVs = tyCoVarsOfCosSet cenv + +-- | This checks if the substitution satisfies the invariant from +-- Note [The substitution invariant]. +checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a + = ASSERT2( isValidTCvSubst subst, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$ + text "cenv" <+> ppr cenv $$ + text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos ) + ASSERT2( tysCosFVsInScope, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "cenv" <+> ppr cenv $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos $$ + text "needInScope" <+> ppr needInScope ) + a + where + substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv + -- It's OK to use nonDetKeysUFM here, because we only use this list to + -- remove some elements from a set + needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) + `delListFromUniqSet_Directly` substDomain + tysCosFVsInScope = needInScope `varSetInScope` in_scope + + +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTy :: HasCallStack => TCvSubst -> Type -> Type +substTy subst ty + | isEmptyTCvSubst subst = ty + | otherwise = checkValidSubst subst [ty] [] $ + subst_ty subst ty + +-- | Substitute within a 'Type' disabling the sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] +substTys subst tys + | isEmptyTCvSubst subst = tys + | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) 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]. +-- The goal of #11371 is to migrate all the calls of substTysUnchecked to +-- substTys and remove this function. Please don't use in new code. +substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +-- | Substitute within a 'ThetaType' disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to +-- substTheta and remove this function. Please don't use in new code. +substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked = substTysUnchecked + + +subst_ty :: TCvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- 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 + !res' = go res + in ty { ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of + (subst', tv') -> + (ForAllTy $! ((Bndr $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: TCvSubst -> TyVar -> Type +substTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion +substCo subst co + | isEmptyTCvSubst subst = co + | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + +-- | Substitute within a 'Coercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos + | isEmptyTCvSubst subst = cos + | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go_mco :: MCoercion -> MCoercion + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go :: Coercion -> Coercion + go (Refl ty) = mkNomReflCo $! (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) + go (TyConAppCo r tc args)= let args' = map go args + in args' `seqList` mkTyConAppCo r tc args' + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv kind_co 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 (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) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (NthCo r d co) = mkNthCo r d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (AxiomRuleCo c cs) = let cs1 = map go cs + in cs1 `seqList` AxiomRuleCo c cs1 + go (HoleCo h) = HoleCo $! go_hole h + + go_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) + = h { ch_co_var = updateVarType go_ty cv } + +substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrUsing False (substCo subst) subst + +-- | Like 'substForAllCoBndr', but disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked subst + = substForAllCoBndrUsing False (substCoUnchecked subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sym sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var + +substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> KindCoercion + -> (TCvSubst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + = ASSERT( isTyVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change && not sym = delVarEnv tenv old_var + | sym = extendVarEnv tenv old_var $ + TyVarTy new_var `CastTy` new_kind_co + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair new_ki1 _ = coercionKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> CoVar -> KindCoercion + -> (TCvSubst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ASSERT( isCoVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change && not sym = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair h1 h2 = coercionKind new_kind_co + + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type + new_var_type | sym = h2 + | otherwise = h1 + +substCoVar :: TCvSubst -> CoVar -> Coercion +substCoVar (TCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrUsing substTy + +substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs = mapAccumL substTyVarBndr + +substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (TCvSubst -> Type -> Type) + -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsing + :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) + ASSERT( isTyVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubst] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + -- The uniqAway part makes sure the new variable is not already in scope + +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + new_co = mkCoVarCo new_var + no_kind_change = noFreeVarsOfTypes [t1, t2] + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 + new_var_type = mkCoercionType role t1' t2' + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) +cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq + = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars + (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + where + old_ki = tyVarKind tv + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + + tv1 | no_kind_change = tv + | otherwise = setTyVarKind tv (substTy subst old_ki) + + tv' = setVarUnique tv1 uniq + +cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' + diff --git a/compiler/types/TyCoTidy.hs b/compiler/types/TyCoTidy.hs new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoTidy.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Tidying types and coercions for printing in error messages. +module TyCoTidy + ( + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos, + tidyTyCoVarBinder, tidyTyCoVarBinders + ) where + +import GhcPrelude + +import TyCoRep +import TyCoFVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) + +import Name hiding (varName) +import Var +import VarEnv +import Util (seqList) + +import Data.List + +{- +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs + +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (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) + name' = tidyNameOcc name occ' + name = varName var + +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Note [Tidying multiple names at once] in OccName +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + +getHelpfulOccName :: TyCoVar -> OccName +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOcc (occNameString occ ++ "0") + | otherwise + = occ + where + name = varName tv + occ = getOccName name + +tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyTyCoVarBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) + where + (tidy_env', tv') = tidyVarBndr tidy_env tv + +tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyTyCoVarBinders tidy_env tvbs + = mapAccumL tidyTyCoVarBinder + (avoidNameClashes (binderVars tvbs) tidy_env) tvbs + +--------------- +tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) + +--------------- +tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars + +--------------- +tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> + let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) + in tidyVarBndr env' tyvar -- Treat it as a binder + +--------------- +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> updateVarType (tidyType env) tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +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@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty + where + (tvs, vis, body_ty) = splitForAllTys' ty + (env', tvs') = tidyVarBndrs env tvs +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + + +-- The following two functions differ from mkForAllTys and splitForAllTys in that +-- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but +-- how should they be named? +mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs + where + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty + +splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTys' ty = go ty [] [] + where + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) + + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys + = (env', tidyTypes (trimmed_occ_env, var_env) tys) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ + tyCoVarsOfTypesWellScoped tys + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the types, so that we don't gratuitously rename + -- the _bound_ variables of the types. + +--------------- +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in + (env', ty') + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType + +---------------- +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go (Refl ty) = Refl (tidyType env ty) + go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp 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 (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (HoleCo h) = HoleCo h + go (AxiomInstCo con ind cos) = let args = map go cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + tidyType env t1) $! tidyType env t2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo r d co) = NthCo r d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos + in cos1 `seqList` AxiomRuleCo ax cos1 + + go_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) + + diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -132,7 +132,8 @@ import GhcPrelude -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType, mkForAllTy, mkFunTy ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, mkForAllTy, mkFunTy ) +import {-# SOURCE #-} TyCoPpr ( pprType ) import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels @@ -1019,6 +1020,7 @@ -- constructor of 'PrimRep'. This data structure allows us to store this -- information right in the 'TyCon'. The other approach would be to look -- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +-- See also Note [Getting from RuntimeRep to PrimRep] in RepType data RuntimeRepInfo = NoRRI -- ^ an ordinary promoted data con | RuntimeRep ([Type] -> [PrimRep]) @@ -1392,23 +1394,30 @@ On the other hand, CmmType includes some "nonsense" values, such as CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in RepType. + -} -- | A 'PrimRep' is an abstraction of a type. It contains information that -- the code generator needs in order to pass arguments, return results, --- and store values of this type. +-- and store values of this type. See also Note [RuntimeRep and PrimRep] in RepType +-- and Note [VoidRep] in RepType. data PrimRep = VoidRep | LiftedRep | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value - | IntRep -- ^ Signed, word-sized value - | WordRep -- ^ Unsigned, word-sized value + | Int32Rep -- ^ Signed, 32-bit value | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | IntRep -- ^ Signed, word-sized value | Word8Rep -- ^ Unsigned, 8 bit value - | Word16Rep -- ^ Unsigned, 16 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word32Rep -- ^ Unsigned, 32 bit value | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | WordRep -- ^ Unsigned, word-sized value | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') | FloatRep | DoubleRep @@ -1455,9 +1464,11 @@ primRepSizeB dflags WordRep = wORD_SIZE dflags primRepSizeB _ Int8Rep = 1 primRepSizeB _ Int16Rep = 2 +primRepSizeB _ Int32Rep = 4 primRepSizeB _ Int64Rep = wORD64_SIZE primRepSizeB _ Word8Rep = 1 primRepSizeB _ Word16Rep = 2 +primRepSizeB _ Word32Rep = 4 primRepSizeB _ Word64Rep = wORD64_SIZE primRepSizeB _ FloatRep = fLOAT_SIZE primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -123,6 +123,7 @@ isCoVarType, isEvVarType, isValidJoinPointType, + tyConAppNeedsKindSig, -- (Lifting and boxity) isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType, @@ -214,7 +215,7 @@ pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, - pprTyVar, pprTyVars, + pprTyVar, pprTyVars, debugPprType, pprWithTYPE, -- * Tidying type related things up for printing @@ -240,6 +241,10 @@ import Kind import TyCoRep +import TyCoSubst +import TyCoTidy +import TyCoPpr +import TyCoFVs -- friends: import Var @@ -365,7 +370,7 @@ = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') -- The free vars of 'rhs' should all be bound by 'tenv', so it's -- ok to use 'substTy' here. - -- See also Note [The substitution invariant] in TyCoRep. + -- See also Note [The substitution invariant] in TyCoSubst. -- Its important to use mkAppTys, rather than (foldl AppTy), -- because the function part might well return a -- partially-applied type constructor; indeed, usually will! @@ -2105,108 +2110,6 @@ | otherwise = NomEq -{- -%************************************************************************ -%* * - Well-scoped tyvars -* * -************************************************************************ - -Note [ScopedSort] -~~~~~~~~~~~~~~~~~ -Consider - - foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () - -This function type is implicitly generalised over [a, b, k, k2]. These -variables will be Specified; that is, they will be available for visible -type application. This is because they are written in the type signature -by the user. - -However, we must ask: what order will they appear in? In cases without -dependency, this is easy: we just use the lexical left-to-right ordering -of first occurrence. With dependency, we cannot get off the hook so -easily. - -We thus state: - - * These variables appear in the order as given by ScopedSort, where - the input to ScopedSort is the left-to-right order of first occurrence. - -Note that this applies only to *implicit* quantification, without a -`forall`. If the user writes a `forall`, then we just use the order given. - -ScopedSort is defined thusly (as proposed in #15743): - * Work left-to-right through the input list, with a cursor. - * If variable v at the cursor is depended on by any earlier variable w, - move v immediately before the leftmost such w. - -INVARIANT: The prefix of variables before the cursor form a valid telescope. - -Note that ScopedSort makes sense only after type inference is done and all -types/kinds are fully settled and zonked. - --} - --- | Do a topological sort on a list of tyvars, --- so that binders occur before occurrences --- E.g. given [ a::k, k::*, b::k ] --- it'll return a well-scoped list [ k::*, a::k, b::k ] --- --- This is a deterministic sorting operation --- (that is, doesn't depend on Uniques). --- --- It is also meant to be stable: that is, variables should not --- be reordered unnecessarily. This is specified in Note [ScopedSort] --- See also Note [Ordering of implicit variables] in RnTypes - -scopedSort :: [TyCoVar] -> [TyCoVar] -scopedSort = go [] [] - where - go :: [TyCoVar] -- already sorted, in reverse order - -> [TyCoVarSet] -- each set contains all the variables which must be placed - -- before the tv corresponding to the set; they are accumulations - -- of the fvs in the sorted tvs' kinds - - -- This list is in 1-to-1 correspondence with the sorted tyvars - -- INVARIANT: - -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) - -- That is, each set in the list is a superset of all later sets. - - -> [TyCoVar] -- yet to be sorted - -> [TyCoVar] - go acc _fv_list [] = reverse acc - go acc fv_list (tv:tvs) - = go acc' fv_list' tvs - where - (acc', fv_list') = insert tv acc fv_list - - insert :: TyCoVar -- var to insert - -> [TyCoVar] -- sorted list, in reverse order - -> [TyCoVarSet] -- list of fvs, as above - -> ([TyCoVar], [TyCoVarSet]) -- augmented lists - insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) - insert tv (a:as) (fvs:fvss) - | tv `elemVarSet` fvs - , (as', fvss') <- insert tv as fvss - = (a:as', fvs `unionVarSet` fv_tv : fvss') - - | otherwise - = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) - where - fv_tv = tyCoVarsOfType (tyVarKind tv) - - -- lists not in correspondence - insert _ _ _ = panic "scopedSort" - --- | Get the free vars of a type in scoped order -tyCoVarsOfTypeWellScoped :: Type -> [TyVar] -tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList - --- | Get the free vars of types in scoped order -tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList - ------------- Closing over kinds ----------------- -- | Add the kind variables free in the kinds of the tyvars in the given set. @@ -3163,3 +3066,270 @@ pprWithTYPE :: Type -> SDoc pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $ ppr ty + + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB VisArg -> injectiveVarsOfType (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` injectiveVarsOfType (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) +2. Converting Types to LHsTypes (in HsUtils.typeToLHsType, or in Haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in TcSplice), and sometimes the +omitted arguments are only the inferred ones (e.g., in HsUtils.typeToLHsType, +which reifies specified arguments through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavey, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + (e.g., HsUtils.typeToLHsType) and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parametrized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -4,7 +4,6 @@ import GhcPrelude import TyCon -import Var ( TyCoVar ) import {-# SOURCE #-} TyCoRep( Type, Coercion ) import Util @@ -20,7 +19,4 @@ coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type -tyCoVarsOfTypesWellScoped :: [Type] -> [TyCoVar] -tyCoVarsOfTypeWellScoped :: Type -> [TyCoVar] -scopedSort :: [TyCoVar] -> [TyCoVar] splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -35,7 +35,9 @@ import Type hiding ( getTvSubstEnv ) import Coercion hiding ( getCvSubstEnv ) import TyCon -import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) +import TyCoRep +import TyCoFVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import TyCoSubst ( mkTvSubst ) import FV( FV, fvVarSet, fvVarList ) import Util import Pair diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -651,6 +651,8 @@ put_ bh Word8Rep = putByte bh 13 put_ bh Int16Rep = putByte bh 14 put_ bh Word16Rep = putByte bh 15 + put_ bh Int32Rep = putByte bh 16 + put_ bh Word32Rep = putByte bh 17 #endif get bh = do @@ -673,6 +675,8 @@ 13 -> pure Word8Rep 14 -> pure Int16Rep 15 -> pure Word16Rep + 16 -> pure Int32Rep + 17 -> pure Word32Rep #endif _ -> fail "Binary.putRuntimeRep: invalid tag" diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs --- a/compiler/utils/ListSetOps.hs +++ b/compiler/utils/ListSetOps.hs @@ -52,8 +52,17 @@ -} -unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a] --- Assumes that the arguments contain no duplicates +-- | Assumes that the arguments contain no duplicates +unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] +-- We special case some reasonable common patterns. +unionLists xs [] = xs +unionLists [] ys = ys +unionLists [x] ys + | isIn "unionLists" x ys = ys + | otherwise = x:ys +unionLists xs [y] + | isIn "unionLists" y xs = xs + | otherwise = y:xs unionLists xs ys = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -576,7 +576,7 @@ isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool -# ifndef DEBUG +# if !defined(DEBUG) isIn _msg x ys = x `elem` ys isn'tIn _msg x ys = x `notElem` ys diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser -version: 0.20190703 +version: 0.20190806 license: BSD3 license-file: LICENSE category: Development @@ -45,11 +45,10 @@ ghc-lib/stage1/compiler/build/Config.hs ghc-lib/stage0/compiler/build/Parser.hs ghc-lib/stage0/compiler/build/Lexer.hs - includes/*.h + ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs + includes/ghcconfig.h + includes/MachDeps.h includes/CodeGen.Platform.hs - includes/rts/*.h - includes/rts/storage/*.h - includes/rts/prof/*.h compiler/nativeGen/*.h compiler/utils/*.h compiler/*.h @@ -62,6 +61,7 @@ default-language: Haskell2010 default-extensions: NoImplicitPrelude include-dirs: + includes ghc-lib/generated ghc-lib/stage0/compiler/build ghc-lib/stage1/compiler/build @@ -127,6 +127,7 @@ compiler/cbits/genSym.c compiler/parser/cutils.c hs-source-dirs: + ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/libraries/ghc-heap/build ghc-lib/stage0/libraries/ghci/build ghc-lib/stage0/compiler/build @@ -135,23 +136,23 @@ libraries/ghc-boot-th compiler/basicTypes compiler/specialise - libraries/ghc-heap - libraries/ghc-boot compiler/nativeGen compiler/profiling compiler/simplCore compiler/typecheck + libraries/ghc-boot + libraries/ghc-heap compiler/backpack compiler/simplStg compiler/coreSyn compiler/deSugar compiler/prelude compiler/parser - libraries/ghci compiler/hsSyn compiler/iface compiler/types compiler/utils + libraries/ghci compiler/ghci compiler/main compiler/cmm @@ -233,6 +234,8 @@ GHC.PackageDb GHC.Platform GHC.Serialized + GHC.UniqueSubdir + GHC.Version GHCi.BreakArray GHCi.FFI GHCi.Message @@ -329,7 +332,11 @@ ToIface ToolSettings TrieMap + TyCoFVs + TyCoPpr TyCoRep + TyCoSubst + TyCoTidy TyCon Type TysPrim diff --git a/ghc-lib/generated/ghcplatform.h b/ghc-lib/generated/ghcplatform.h --- a/ghc-lib/generated/ghcplatform.h +++ b/ghc-lib/generated/ghcplatform.h @@ -22,13 +22,5 @@ #define BUILD_VENDOR "apple" #define HOST_VENDOR "apple" -/* These TARGET macros are for backwards compatibility... DO NOT USE! */ -#define TargetPlatform_TYPE x86_64_apple_darwin -#define x86_64_apple_darwin_TARGET 1 -#define x86_64_TARGET_ARCH 1 -#define TARGET_ARCH "x86_64" -#define darwin_TARGET_OS 1 -#define TARGET_OS "darwin" -#define apple_TARGET_VENDOR 1 #endif /* __GHCPLATFORM_H__ */ diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190703 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190804 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/compiler/build/Lexer.hs b/ghc-lib/stage0/compiler/build/Lexer.hs --- a/ghc-lib/stage0/compiler/build/Lexer.hs +++ b/ghc-lib/stage0/compiler/build/Lexer.hs @@ -10,7 +10,10 @@ module Lexer ( Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), - P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags, + P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..), + appendWarning, + appendError, + allocateComments, MonadP(..), getRealSrcLoc, getPState, withThisPackage, failLocMsgP, srcParseFail, @@ -19,8 +22,10 @@ activeContext, nextIsEOF, getLexState, popLexState, pushLexState, ExtBits(..), + xtest, lexTokenStream, - AddAnn,mkParensApiAnn, + AddAnn(..),mkParensApiAnn, + addAnnsAt, commentToAnnotation ) where @@ -555,7 +560,7 @@ , (0,alex_action_114) ] -{-# LINE 578 "compiler/parser/Lexer.x" #-} +{-# LINE 583 "compiler/parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- @@ -2484,41 +2489,56 @@ -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool -- | Given a location and a list of AddAnn, apply them all to the location. - addAnnsAt :: SrcSpan -> [AddAnn] -> m () addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct -> AnnKeywordId -- The first two parameters are the key -> SrcSpan -- The location of the keyword itself -> m () +appendError + :: SrcSpan + -> SDoc + -> (DynFlags -> Messages) + -> (DynFlags -> Messages) +appendError srcspan msg m = + \d -> + let (ws, es) = m d + errormsg = mkErrMsg d srcspan alwaysQualify msg + es' = es `snocBag` errormsg + in (ws, es') + +appendWarning + :: ParserFlags + -> WarningFlag + -> SrcSpan + -> SDoc + -> (DynFlags -> Messages) + -> (DynFlags -> Messages) +appendWarning o option srcspan warning m = + \d -> + let (ws, es) = m d + warning' = makeIntoWarning (Reason option) $ + mkWarnMsg d srcspan alwaysQualify warning + ws' = if warnopt option o then ws `snocBag` warning' else ws + in (ws', es) + instance MonadP P where addError srcspan msg = P $ \s@PState{messages=m} -> - let - m' d = - let (ws, es) = m d - errormsg = mkErrMsg d srcspan alwaysQualify msg - es' = es `snocBag` errormsg - in (ws, es') - in POk s{messages=m'} () + POk s{messages=appendError srcspan msg m} () addWarning option srcspan warning = P $ \s@PState{messages=m, options=o} -> - let - m' d = - let (ws, es) = m d - warning' = makeIntoWarning (Reason option) $ - mkWarnMsg d srcspan alwaysQualify warning - ws' = if warnopt option o then ws `snocBag` warning' else ws - in (ws', es) - in POk s{messages=m'} () + POk s{messages=appendWarning o option srcspan warning m} () addFatalError span msg = addError span msg >> P PFailed getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) in b `seq` POk s b - addAnnsAt loc anns = mapM_ (\a -> a loc) anns addAnnotation l a v = do addAnnotationOnly l a v - allocateComments l + allocateCommentsP l +addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m () +addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v) + addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> @@ -3042,7 +3062,7 @@ -- -- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") -- function, and then it can be discharged using the 'ams' function. -type AddAnn = SrcSpan -> P () +data AddAnn = AddAnn AnnKeywordId SrcSpan addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () addAnnotationOnly l a v = P $ \s -> POk s { @@ -3054,9 +3074,8 @@ -- and end of the span mkParensApiAnn :: SrcSpan -> [AddAnn] mkParensApiAnn (UnhelpfulSpan _) = [] -mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] +mkParensApiAnn s@(RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] where - mj a l = (\s -> addAnnotation s a l) f = srcSpanFile ss sl = srcSpanStartLine ss sc = srcSpanStartCol ss @@ -3072,19 +3091,28 @@ -- | Go through the @comment_q@ in @PState@ and remove all comments -- that belong within the given span -allocateComments :: SrcSpan -> P () -allocateComments ss = P $ \s -> +allocateCommentsP :: SrcSpan -> P () +allocateCommentsP ss = P $ \s -> + let (comment_q', newAnns) = allocateComments ss (comment_q s) in + POk s { + comment_q = comment_q' + , annotations_comments = newAnns ++ (annotations_comments s) + } () + +allocateComments + :: SrcSpan + -> [Located AnnotationComment] + -> ([Located AnnotationComment], [(SrcSpan,[Located AnnotationComment])]) +allocateComments ss comment_q = let - (before,rest) = break (\(L l _) -> isSubspanOf l ss) (comment_q s) + (before,rest) = break (\(L l _) -> isSubspanOf l ss) comment_q (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest comment_q' = before ++ after newAnns = if null middle then [] else [(ss,middle)] in - POk s { - comment_q = comment_q' - , annotations_comments = newAnns ++ (annotations_comments s) - } () + (comment_q', newAnns) + commentToAnnotation :: Located Token -> Located AnnotationComment commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs --- a/ghc-lib/stage0/compiler/build/Parser.hs +++ b/ghc-lib/stage0/compiler/build/Parser.hs @@ -4073,7 +4073,7 @@ happyReduction_96 happy_x_1 = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> happyIn52 - (unitOL (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> IEGroup noExt n doc)) + (unitOL (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> IEGroup noExtField n doc)) )} happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4081,7 +4081,7 @@ happyReduction_97 happy_x_1 = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> happyIn52 - (unitOL (sL1 happy_var_1 (IEDocNamed noExt ((fst . unLoc) happy_var_1))) + (unitOL (sL1 happy_var_1 (IEDocNamed noExtField ((fst . unLoc) happy_var_1))) )} happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4089,7 +4089,7 @@ happyReduction_98 happy_x_1 = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> happyIn52 - (unitOL (sL1 happy_var_1 (IEDoc noExt (unLoc happy_var_1))) + (unitOL (sL1 happy_var_1 (IEDoc noExtField (unLoc happy_var_1))) )} happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4110,7 +4110,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> - ( amsu (sLL happy_var_1 happy_var_2 (IEModuleContents noExt happy_var_2)) + ( amsu (sLL happy_var_1 happy_var_2 (IEModuleContents noExtField happy_var_2)) [mj AnnModule happy_var_1])}}) ) (\r -> happyReturn (happyIn53 r)) @@ -4121,7 +4121,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> - ( amsu (sLL happy_var_1 happy_var_2 (IEVar noExt (sLL happy_var_1 happy_var_2 (IEPattern happy_var_2)))) + ( amsu (sLL happy_var_1 happy_var_2 (IEVar noExtField (sLL happy_var_1 happy_var_2 (IEPattern happy_var_2)))) [mj AnnPattern happy_var_1])}}) ) (\r -> happyReturn (happyIn53 r)) @@ -4323,7 +4323,7 @@ ( do { ; checkImportDecl happy_var_4 happy_var_7 ; ams (cL (comb4 happy_var_1 happy_var_6 (snd happy_var_8) happy_var_9) $ - ImportDecl { ideclExt = noExt + ImportDecl { ideclExt = noExtField , ideclSourceSrc = snd $ fst happy_var_2 , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 @@ -4557,7 +4557,7 @@ happyReduction_146 happy_x_1 = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> happyIn77 - (sL1 happy_var_1 (TyClD noExt (unLoc happy_var_1)) + (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) )} happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4565,7 +4565,7 @@ happyReduction_147 happy_x_1 = case happyOut79 happy_x_1 of { (HappyWrap79 happy_var_1) -> happyIn77 - (sL1 happy_var_1 (TyClD noExt (unLoc happy_var_1)) + (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) )} happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4573,7 +4573,7 @@ happyReduction_148 happy_x_1 = case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> happyIn77 - (sL1 happy_var_1 (InstD noExt (unLoc happy_var_1)) + (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)) )} happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4581,7 +4581,7 @@ happyReduction_149 happy_x_1 = case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> happyIn77 - (sLL happy_var_1 happy_var_1 (DerivD noExt (unLoc happy_var_1)) + (sLL happy_var_1 happy_var_1 (DerivD noExtField (unLoc happy_var_1)) )} happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4589,7 +4589,7 @@ happyReduction_150 happy_x_1 = case happyOut105 happy_x_1 of { (HappyWrap105 happy_var_1) -> happyIn77 - (sL1 happy_var_1 (RoleAnnotD noExt (unLoc happy_var_1)) + (sL1 happy_var_1 (RoleAnnotD noExtField (unLoc happy_var_1)) )} happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -4603,7 +4603,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 (DefD noExt (DefaultDecl noExt happy_var_3))) + ( ams (sLL happy_var_1 happy_var_4 (DefD noExtField (DefaultDecl noExtField happy_var_3))) [mj AnnDefault happy_var_1 ,mop happy_var_2,mcp happy_var_4])}}}}) ) (\r -> happyReturn (happyIn77 r)) @@ -4628,7 +4628,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ WarningD noExt (Warnings noExt (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))) + ( ams (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn77 r)) @@ -4641,7 +4641,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ WarningD noExt (Warnings noExt (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))) + ( ams (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn77 r)) @@ -4654,7 +4654,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ RuleD noExt (HsRules noExt (getRULES_PRAGs happy_var_1) (fromOL happy_var_2))) + ( ams (sLL happy_var_1 happy_var_3 $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs happy_var_1) (fromOL happy_var_2))) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn77 r)) @@ -4806,13 +4806,13 @@ case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> case happyOut122 happy_x_4 of { (HappyWrap122 happy_var_4) -> ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4) - ; let cid = ClsInstDecl { cid_ext = noExt + ; let cid = ClsInstDecl { cid_ext = noExtField , cid_poly_ty = happy_var_3, cid_binds = binds , cid_sigs = mkClassOpSigs sigs , cid_tyfam_insts = ats , cid_overlap_mode = happy_var_2 , cid_datafam_insts = adts } - ; ams (cL (comb3 happy_var_1 (hsSigType happy_var_3) happy_var_4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) + ; ams (cL (comb3 happy_var_1 (hsSigType happy_var_3) happy_var_4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4)) })}}}}) ) (\r -> happyReturn (happyIn80 r)) @@ -5430,7 +5430,7 @@ happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_218 = happySpecReduce_0 82# happyReduction_218 happyReduction_218 = happyIn98 - (noLoc ([] , noLoc (NoSig noExt) ) + (noLoc ([] , noLoc (NoSig noExtField) ) ) happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -5440,13 +5440,13 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> happyIn98 - (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExt happy_var_2)) + (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) )}} happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_220 = happySpecReduce_0 83# happyReduction_220 happyReduction_220 = happyIn99 - (noLoc ([] , noLoc (NoSig noExt) ) + (noLoc ([] , noLoc (NoSig noExtField) ) ) happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -5456,7 +5456,7 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> happyIn99 - (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExt happy_var_2)) + (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) )}} happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -5466,13 +5466,13 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> happyIn99 - (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1] , sLL happy_var_1 happy_var_2 (TyVarSig noExt happy_var_2)) + (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1] , sLL happy_var_1 happy_var_2 (TyVarSig noExtField happy_var_2)) )}} happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_223 = happySpecReduce_0 84# happyReduction_223 happyReduction_223 = happyIn100 - (noLoc ([], (noLoc (NoSig noExt), Nothing)) + (noLoc ([], (noLoc (NoSig noExtField), Nothing)) ) happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -5483,7 +5483,7 @@ case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> happyIn100 (sLL happy_var_1 happy_var_2 ( [mu AnnDcolon happy_var_1] - , (sLL happy_var_2 happy_var_2 (KindSig noExt happy_var_2), Nothing)) + , (sLL happy_var_2 happy_var_2 (KindSig noExtField happy_var_2), Nothing)) )}} happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -5499,7 +5499,7 @@ case happyOut86 happy_x_4 of { (HappyWrap86 happy_var_4) -> happyIn100 (sLL happy_var_1 happy_var_4 ([mj AnnEqual happy_var_1, mj AnnVbar happy_var_3] - , (sLL happy_var_1 happy_var_2 (TyVarSig noExt happy_var_2), Just happy_var_4)) + , (sLL happy_var_1 happy_var_2 (TyVarSig noExtField happy_var_2), Just happy_var_4)) ) `HappyStk` happyRest}}}} happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -5633,7 +5633,7 @@ ( do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr happy_var_5) } ; ams (sLL happy_var_1 (hsSigType happy_var_5) - (DerivDecl noExt (mkHsWildCardBndrs happy_var_5) happy_var_2 happy_var_4)) + (DerivDecl noExtField (mkHsWildCardBndrs happy_var_5) happy_var_2 happy_var_4)) [mj AnnDeriving happy_var_1, mj AnnInstance happy_var_3] })}}}}}) ) (\r -> happyReturn (happyIn104 r)) @@ -5712,7 +5712,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut247 happy_x_4 of { (HappyWrap247 happy_var_4) -> ( let (name, args,as ) = happy_var_2 in - ams (sLL happy_var_1 happy_var_4 . ValD noExt $ mkPatSynBind name args happy_var_4 + ams (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 ImplicitBidirectional) (as ++ [mj AnnPattern happy_var_1, mj AnnEqual happy_var_3]))}}}}) ) (\r -> happyReturn (happyIn109 r)) @@ -5729,7 +5729,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut247 happy_x_4 of { (HappyWrap247 happy_var_4) -> ( let (name, args, as) = happy_var_2 in - ams (sLL happy_var_1 happy_var_4 . ValD noExt $ mkPatSynBind name args happy_var_4 Unidirectional) + ams (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 Unidirectional) (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]))}}}}) ) (\r -> happyReturn (happyIn109 r)) @@ -5748,7 +5748,7 @@ case happyOut113 happy_x_5 of { (HappyWrap113 happy_var_5) -> ( do { let (name, args, as) = happy_var_2 ; mg <- mkPatSynMatchGroup name (snd $ unLoc happy_var_5) - ; ams (sLL happy_var_1 happy_var_5 . ValD noExt $ + ; ams (sLL happy_var_1 happy_var_5 . ValD noExtField $ mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg)) (as ++ ((mj AnnPattern happy_var_1:mu AnnLarrow happy_var_3:(fst $ unLoc happy_var_5))) ) })}}}}}) @@ -5869,7 +5869,7 @@ case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut148 happy_x_4 of { (HappyWrap148 happy_var_4) -> - ( ams (sLL happy_var_1 happy_var_4 $ PatSynSig noExt (unLoc happy_var_2) (mkLHsSigType happy_var_4)) + ( ams (sLL happy_var_1 happy_var_4 $ PatSynSig noExtField (unLoc happy_var_2) (mkLHsSigType happy_var_4)) [mj AnnPattern happy_var_1, mu AnnDcolon happy_var_3])}}}}) ) (\r -> happyReturn (happyIn114 r)) @@ -5904,7 +5904,7 @@ do { v <- checkValSigLhs happy_var_2 ; let err = text "in default signature" <> colon <+> quotes (ppr happy_var_2) - ; ams (sLL happy_var_1 happy_var_4 $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType happy_var_4) + ; ams (sLL happy_var_1 happy_var_4 $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType happy_var_4) [mj AnnDefault happy_var_1,mu AnnDcolon happy_var_3] })}}}}) ) (\r -> happyReturn (happyIn115 r)) @@ -5998,7 +5998,7 @@ happyReduction_267 happy_x_1 = case happyOut95 happy_x_1 of { (HappyWrap95 happy_var_1) -> happyIn119 - (sLL happy_var_1 happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExt (unLoc happy_var_1)))) + (sLL happy_var_1 happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)))) )} happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -6173,7 +6173,7 @@ = happyThen ((case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> ( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1) ; return (sL1 happy_var_1 (fst $ unLoc happy_var_1 - ,sL1 happy_var_1 $ HsValBinds noExt val_binds)) })}) + ,sL1 happy_var_1 $ HsValBinds noExtField val_binds)) })}) ) (\r -> happyReturn (happyIn125 r)) happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -6186,7 +6186,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> happyIn125 (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] - ,sL1 happy_var_2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc happy_var_2))) + ,sL1 happy_var_2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc happy_var_2))) )}}} happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -6197,7 +6197,7 @@ = case happyOut260 happy_x_2 of { (HappyWrap260 happy_var_2) -> happyIn125 (cL (getLoc happy_var_2) ([] - ,sL1 happy_var_2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc happy_var_2))) + ,sL1 happy_var_2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc happy_var_2))) )} happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -6272,7 +6272,7 @@ case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> (runECP_P happy_var_4 >>= \ happy_var_4 -> runECP_P happy_var_6 >>= \ happy_var_6 -> - ams (sLL happy_var_1 happy_var_6 $ HsRule { rd_ext = noExt + ams (sLL happy_var_1 happy_var_6 $ HsRule { rd_ext = noExtField , rd_name = cL (gl happy_var_1) (getSTRINGs happy_var_1, getSTRING happy_var_1) , rd_act = (snd happy_var_2) `orElse` AlwaysActive , rd_tyvs = sndOf3 happy_var_3, rd_tmvs = thdOf3 happy_var_3 @@ -6464,7 +6464,7 @@ happyRest) tk = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> - ( amsu (sLL happy_var_1 happy_var_2 (Warning noExt (unLoc happy_var_1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) + ( amsu (sLL happy_var_1 happy_var_2 (Warning noExtField (unLoc happy_var_1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) (fst $ unLoc happy_var_2))}}) ) (\r -> happyReturn (happyIn135 r)) @@ -6513,7 +6513,7 @@ happyRest) tk = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> - ( amsu (sLL happy_var_1 happy_var_2 $ (Warning noExt (unLoc happy_var_1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) + ( amsu (sLL happy_var_1 happy_var_2 $ (Warning noExtField (unLoc happy_var_1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) (fst $ unLoc happy_var_2))}}) ) (\r -> happyReturn (happyIn137 r)) @@ -6577,7 +6577,7 @@ case happyOut216 happy_x_3 of { (HappyWrap216 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( runECP_P happy_var_3 >>= \ happy_var_3 -> - ams (sLL happy_var_1 happy_var_4 (AnnD noExt $ HsAnnotation noExt + ams (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs happy_var_1) (ValueAnnProvenance happy_var_2) happy_var_3)) [mo happy_var_1,mc happy_var_4])}}}}) @@ -6597,7 +6597,7 @@ case happyOut216 happy_x_4 of { (HappyWrap216 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> - ams (sLL happy_var_1 happy_var_5 (AnnD noExt $ HsAnnotation noExt + ams (sLL happy_var_1 happy_var_5 (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs happy_var_1) (TypeAnnProvenance happy_var_3) happy_var_4)) [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_5])}}}}}) @@ -6615,7 +6615,7 @@ case happyOut216 happy_x_3 of { (HappyWrap216 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( runECP_P happy_var_3 >>= \ happy_var_3 -> - ams (sLL happy_var_1 happy_var_4 (AnnD noExt $ HsAnnotation noExt + ams (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs happy_var_1) ModuleAnnProvenance happy_var_3)) [mo happy_var_1,mj AnnModule happy_var_2,mc happy_var_4])}}}}) @@ -6900,7 +6900,7 @@ = happyThen ((case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut179 happy_x_3 of { (HappyWrap179 happy_var_3) -> - ( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExt happy_var_1 happy_var_3) + ( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExtField happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn153 r)) @@ -6921,7 +6921,7 @@ = happyThen ((case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut179 happy_x_3 of { (HappyWrap179 happy_var_3) -> - ( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExt happy_var_1 happy_var_3) + ( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExtField happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn154 r)) @@ -6941,7 +6941,7 @@ ams (sLL happy_var_1 happy_var_4 $ HsForAllTy { hst_fvf = fv_flag , hst_bndrs = happy_var_2 - , hst_xforall = noExt + , hst_xforall = noExtField , hst_body = happy_var_4 }) [mu AnnForall happy_var_1,fv_ann])}}}}) ) (\r -> happyReturn (happyIn155 r)) @@ -6958,7 +6958,7 @@ ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 $ HsQualTy { hst_ctxt = happy_var_1 - , hst_xqual = noExt + , hst_xqual = noExtField , hst_body = happy_var_3 }))}}}) ) (\r -> happyReturn (happyIn155 r)) @@ -6971,7 +6971,7 @@ = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExt happy_var_1 happy_var_3)) + ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExtField happy_var_1 happy_var_3)) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn155 r)) @@ -6999,7 +6999,7 @@ ams (sLL happy_var_1 happy_var_4 $ HsForAllTy { hst_fvf = fv_flag , hst_bndrs = happy_var_2 - , hst_xforall = noExt + , hst_xforall = noExtField , hst_body = happy_var_4 }) [mu AnnForall happy_var_1,fv_ann])}}}}) ) (\r -> happyReturn (happyIn156 r)) @@ -7016,7 +7016,7 @@ ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 $ HsQualTy { hst_ctxt = happy_var_1 - , hst_xqual = noExt + , hst_xqual = noExtField , hst_body = happy_var_3 }))}}}) ) (\r -> happyReturn (happyIn156 r)) @@ -7029,7 +7029,7 @@ = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExt happy_var_1 happy_var_3)) + ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExtField happy_var_1 happy_var_3)) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn156 r)) @@ -7085,7 +7085,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] - >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExt happy_var_1 happy_var_3) + >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn159 r)) @@ -7104,7 +7104,7 @@ = case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> happyIn160 - (sLL happy_var_1 happy_var_2 $ HsDocTy noExt happy_var_1 happy_var_2 + (sLL happy_var_1 happy_var_2 $ HsDocTy noExtField happy_var_1 happy_var_2 )}} happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7114,7 +7114,7 @@ = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> happyIn160 - (sLL happy_var_1 happy_var_2 $ HsDocTy noExt happy_var_2 happy_var_1 + (sLL happy_var_1 happy_var_2 $ HsDocTy noExtField happy_var_2 happy_var_1 )}} happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7127,7 +7127,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut156 happy_x_3 of { (HappyWrap156 happy_var_3) -> ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] - >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExt happy_var_1 happy_var_3) + >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn160 r)) @@ -7144,8 +7144,8 @@ case happyOut156 happy_x_4 of { (HappyWrap156 happy_var_4) -> ( ams happy_var_1 [mu AnnRarrow happy_var_3] -- See note [GADT decl discards annotations] >> ams (sLL happy_var_1 happy_var_4 $ - HsFunTy noExt (cL (comb2 happy_var_1 happy_var_2) - (HsDocTy noExt happy_var_1 happy_var_2)) + HsFunTy noExtField (cL (comb2 happy_var_1 happy_var_2) + (HsDocTy noExtField happy_var_1 happy_var_2)) happy_var_4) [mu AnnRarrow happy_var_3])}}}}) ) (\r -> happyReturn (happyIn160 r)) @@ -7163,8 +7163,8 @@ case happyOut156 happy_x_4 of { (HappyWrap156 happy_var_4) -> ( ams happy_var_2 [mu AnnRarrow happy_var_3] -- See note [GADT decl discards annotations] >> ams (sLL happy_var_1 happy_var_4 $ - HsFunTy noExt (cL (comb2 happy_var_1 happy_var_2) - (HsDocTy noExt happy_var_2 happy_var_1)) + HsFunTy noExtField (cL (comb2 happy_var_1 happy_var_2) + (HsDocTy noExtField happy_var_2 happy_var_1)) happy_var_4) [mu AnnRarrow happy_var_3])}}}}) ) (\r -> happyReturn (happyIn160 r)) @@ -7308,7 +7308,7 @@ happyReduction_387 happy_x_1 = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> happyIn167 - (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1) + (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1) )} happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7316,7 +7316,7 @@ happyReduction_388 happy_x_1 = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> happyIn167 - (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1) + (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1) )} happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7325,7 +7325,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( do { warnStarIsType (getLoc happy_var_1) - ; return $ sL1 happy_var_1 (HsStarTy noExt (isUnicode happy_var_1)) })}) + ; return $ sL1 happy_var_1 (HsStarTy noExtField (isUnicode happy_var_1)) })}) ) (\r -> happyReturn (happyIn167 r)) happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7338,7 +7338,7 @@ case happyOut189 happy_x_2 of { (HappyWrap189 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( amms (checkRecordSyntax - (sLL happy_var_1 happy_var_3 $ HsRecTy noExt happy_var_2)) + (sLL happy_var_1 happy_var_3 $ HsRecTy noExtField happy_var_2)) -- Constructor sigs only [moc happy_var_1,mcc happy_var_3])}}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7350,7 +7350,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExt + ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExtField HsBoxedOrConstraintTuple []) [mop happy_var_1,mcp happy_var_2])}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7370,7 +7370,7 @@ case happyOutTok happy_x_5 of { happy_var_5 -> ( addAnnotation (gl happy_var_2) AnnComma (gl happy_var_3) >> - ams (sLL happy_var_1 happy_var_5 $ HsTupleTy noExt + ams (sLL happy_var_1 happy_var_5 $ HsTupleTy noExtField HsBoxedOrConstraintTuple (happy_var_2 : happy_var_4)) [mop happy_var_1,mcp happy_var_5])}}}}}) @@ -7383,7 +7383,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExt HsUnboxedTuple []) + ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExtField HsUnboxedTuple []) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7396,7 +7396,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut171 happy_x_2 of { (HappyWrap171 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsTupleTy noExt HsUnboxedTuple happy_var_2) + ( ams (sLL happy_var_1 happy_var_3 $ HsTupleTy noExtField HsUnboxedTuple happy_var_2) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7409,7 +7409,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsSumTy noExt happy_var_2) + ( ams (sLL happy_var_1 happy_var_3 $ HsSumTy noExtField happy_var_2) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7422,7 +7422,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsListTy noExt happy_var_2) [mos happy_var_1,mcs happy_var_3])}}}) + ( ams (sLL happy_var_1 happy_var_3 $ HsListTy noExtField happy_var_2) [mos happy_var_1,mcs happy_var_3])}}}) ) (\r -> happyReturn (happyIn167 r)) happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7434,7 +7434,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ HsParTy noExt happy_var_2) [mop happy_var_1,mcp happy_var_3])}}}) + ( ams (sLL happy_var_1 happy_var_3 $ HsParTy noExtField happy_var_2) [mop happy_var_1,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn167 r)) happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7442,7 +7442,7 @@ happyReduction_398 happy_x_1 = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> happyIn167 - (mapLoc (HsSpliceTy noExt) happy_var_1 + (mapLoc (HsSpliceTy noExtField) happy_var_1 )} happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7450,7 +7450,7 @@ happyReduction_399 happy_x_1 = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> happyIn167 - (mapLoc (HsSpliceTy noExt) happy_var_1 + (mapLoc (HsSpliceTy noExtField) happy_var_1 )} happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7460,7 +7460,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut271 happy_x_2 of { (HappyWrap271 happy_var_2) -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExt IsPromoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) + ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExtField IsPromoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn167 r)) happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7479,7 +7479,7 @@ case happyOut171 happy_x_5 of { (HappyWrap171 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> ( addAnnotation (gl happy_var_3) AnnComma (gl happy_var_4) >> - ams (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy noExt (happy_var_3 : happy_var_5)) + ams (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy noExtField (happy_var_3 : happy_var_5)) [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6])}}}}}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7494,7 +7494,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams (sLL happy_var_1 happy_var_4 $ HsExplicitListTy noExt IsPromoted happy_var_3) + ( ams (sLL happy_var_1 happy_var_4 $ HsExplicitListTy noExtField IsPromoted happy_var_3) [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4])}}}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7505,7 +7505,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> - ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExt IsPromoted happy_var_2) + ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExtField IsPromoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7524,7 +7524,7 @@ case happyOutTok happy_x_5 of { happy_var_5 -> ( addAnnotation (gl happy_var_2) AnnComma (gl happy_var_3) >> - ams (sLL happy_var_1 happy_var_5 $ HsExplicitListTy noExt NotPromoted (happy_var_2 : happy_var_4)) + ams (sLL happy_var_1 happy_var_5 $ HsExplicitListTy noExtField NotPromoted (happy_var_2 : happy_var_4)) [mos happy_var_1,mcs happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn167 r)) @@ -7533,7 +7533,7 @@ happyReduction_405 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn167 - (sLL happy_var_1 happy_var_1 $ HsTyLit noExt $ HsNumTy (getINTEGERs happy_var_1) + (sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) (il_value (getINTEGER happy_var_1)) )} @@ -7542,7 +7542,7 @@ happyReduction_406 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn167 - (sLL happy_var_1 happy_var_1 $ HsTyLit noExt $ HsStrTy (getSTRINGs happy_var_1) + (sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) (getSTRING happy_var_1) )} @@ -7665,7 +7665,7 @@ happyReduction_419 happy_x_1 = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> happyIn174 - (sL1 happy_var_1 (UserTyVar noExt happy_var_1) + (sL1 happy_var_1 (UserTyVar noExtField happy_var_1) )} happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -7681,7 +7681,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut179 happy_x_4 of { (HappyWrap179 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> - ( ams (sLL happy_var_1 happy_var_5 (KindedTyVar noExt happy_var_2 happy_var_4)) + ( ams (sLL happy_var_1 happy_var_5 (KindedTyVar noExtField happy_var_2 happy_var_4)) [mop happy_var_1,mu AnnDcolon happy_var_3 ,mcp happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn174 r)) @@ -8020,7 +8020,7 @@ case happyOut155 happy_x_4 of { (HappyWrap155 happy_var_4) -> case happyOut326 happy_x_5 of { (HappyWrap326 happy_var_5) -> ( ams (cL (comb2 happy_var_2 happy_var_4) - (ConDeclField noExt (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExt ln) (unLoc happy_var_2))) happy_var_4 (happy_var_1 `mplus` happy_var_5))) + (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc happy_var_2))) happy_var_4 (happy_var_1 `mplus` happy_var_5))) [mu AnnDcolon happy_var_3])}}}}}) ) (\r -> happyReturn (happyIn191 r)) @@ -8064,7 +8064,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut195 happy_x_2 of { (HappyWrap195 happy_var_2) -> ( let { full_loc = comb2 happy_var_1 happy_var_2 } - in ams (cL full_loc $ HsDerivingClause noExt Nothing happy_var_2) + in ams (cL full_loc $ HsDerivingClause noExtField Nothing happy_var_2) [mj AnnDeriving happy_var_1])}}) ) (\r -> happyReturn (happyIn194 r)) @@ -8078,7 +8078,7 @@ case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> case happyOut195 happy_x_3 of { (HappyWrap195 happy_var_3) -> ( let { full_loc = comb2 happy_var_1 happy_var_3 } - in ams (cL full_loc $ HsDerivingClause noExt (Just happy_var_2) happy_var_3) + in ams (cL full_loc $ HsDerivingClause noExtField (Just happy_var_2) happy_var_3) [mj AnnDeriving happy_var_1])}}}) ) (\r -> happyReturn (happyIn194 r)) @@ -8092,7 +8092,7 @@ case happyOut195 happy_x_2 of { (HappyWrap195 happy_var_2) -> case happyOut83 happy_x_3 of { (HappyWrap83 happy_var_3) -> ( let { full_loc = comb2 happy_var_1 happy_var_3 } - in ams (cL full_loc $ HsDerivingClause noExt (Just happy_var_3) happy_var_2) + in ams (cL full_loc $ HsDerivingClause noExtField (Just happy_var_3) happy_var_2) [mj AnnDeriving happy_var_1])}}}) ) (\r -> happyReturn (happyIn194 r)) @@ -8133,7 +8133,7 @@ happyReduction_461 happy_x_1 = case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> happyIn196 - (sL1 happy_var_1 (DocD noExt (unLoc happy_var_1)) + (sL1 happy_var_1 (DocD noExtField (unLoc happy_var_1)) )} happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -8200,7 +8200,7 @@ amsL l [] >> return () } ; _ <- amsL l (ann ++ fst (unLoc happy_var_3) ++ [mj AnnBang happy_var_1]) ; - return $! (sL l $ ValD noExt r) })}}}) + return $! (sL l $ ValD noExtField r) })}}}) ) (\r -> happyReturn (happyIn198 r)) happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -8224,7 +8224,7 @@ (PatBind _ (dL->L lh _lhs) _rhs _) -> amsL lh (fst happy_var_2) >> return () } ; _ <- amsL l (ann ++ (fst $ unLoc happy_var_3)); - return $! (sL l $ ValD noExt r) })}}}) + return $! (sL l $ ValD noExtField r) })}}}) ) (\r -> happyReturn (happyIn198 r)) happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -8271,7 +8271,7 @@ ( runECP_P happy_var_2 >>= \ happy_var_2 -> return $ sL (comb3 happy_var_1 happy_var_2 happy_var_3) ((mj AnnEqual happy_var_1 : (fst $ unLoc happy_var_3)) - ,GRHSs noExt (unguardedRHS (comb3 happy_var_1 happy_var_2 happy_var_3) happy_var_2) + ,GRHSs noExtField (unguardedRHS (comb3 happy_var_1 happy_var_2 happy_var_3) happy_var_2) (snd $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn200 r)) @@ -8283,7 +8283,7 @@ case happyOut126 happy_x_2 of { (HappyWrap126 happy_var_2) -> happyIn200 (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2 - ,GRHSs noExt (reverse (unLoc happy_var_1)) + ,GRHSs noExtField (reverse (unLoc happy_var_1)) (snd $ unLoc happy_var_2)) )}} @@ -8317,7 +8317,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> - ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExt (unLoc happy_var_2) happy_var_4) + ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExtField (unLoc happy_var_2) happy_var_4) [mj AnnVbar happy_var_1,mj AnnEqual happy_var_3])}}}}) ) (\r -> happyReturn (happyIn202 r)) @@ -8333,8 +8333,8 @@ ( do { happy_var_1 <- runECP_P happy_var_1 ; v <- checkValSigLhs happy_var_1 ; _ <- amsL (comb2 happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2] - ; return (sLL happy_var_1 happy_var_3 $ SigD noExt $ - TypeSig noExt [v] (mkLHsSigWcType happy_var_3))})}}}) + ; return (sLL happy_var_1 happy_var_3 $ SigD noExtField $ + TypeSig noExtField [v] (mkLHsSigWcType happy_var_3))})}}}) ) (\r -> happyReturn (happyIn203 r)) happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -8350,10 +8350,10 @@ case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut148 happy_x_5 of { (HappyWrap148 happy_var_5) -> - ( do { let sig = TypeSig noExt (happy_var_1 : reverse (unLoc happy_var_3)) + ( do { let sig = TypeSig noExtField (happy_var_1 : reverse (unLoc happy_var_3)) (mkLHsSigWcType happy_var_5) ; addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) - ; ams ( sLL happy_var_1 happy_var_5 $ SigD noExt sig ) + ; ams ( sLL happy_var_1 happy_var_5 $ SigD noExtField sig ) [mu AnnDcolon happy_var_4] })}}}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8367,8 +8367,8 @@ case happyOut72 happy_x_2 of { (HappyWrap72 happy_var_2) -> case happyOut74 happy_x_3 of { (HappyWrap74 happy_var_3) -> ( checkPrecP happy_var_2 happy_var_3 >> - ams (sLL happy_var_1 happy_var_3 $ SigD noExt - (FixSig noExt (FixitySig noExt (fromOL $ unLoc happy_var_3) + ams (sLL happy_var_1 happy_var_3 $ SigD noExtField + (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc happy_var_3) (Fixity (fst $ unLoc happy_var_2) (snd $ unLoc happy_var_2) (unLoc happy_var_1))))) [mj AnnInfix happy_var_1,mj AnnVal happy_var_2])}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8378,7 +8378,7 @@ happyReduction_481 happy_x_1 = case happyOut114 happy_x_1 of { (HappyWrap114 happy_var_1) -> happyIn203 - (sLL happy_var_1 happy_var_1 . SigD noExt . unLoc $ happy_var_1 + (sLL happy_var_1 happy_var_1 . SigD noExtField . unLoc $ happy_var_1 )} happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -8395,7 +8395,7 @@ ( let (dcolon, tc) = happy_var_3 in ams (sLL happy_var_1 happy_var_4 - (SigD noExt (CompleteMatchSig noExt (getCOMPLETE_PRAGs happy_var_1) happy_var_2 tc))) + (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs happy_var_1) happy_var_2 tc))) ([ mo happy_var_1 ] ++ dcolon ++ [mc happy_var_4]))}}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8410,7 +8410,7 @@ case happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> - ( ams ((sLL happy_var_1 happy_var_4 $ SigD noExt (InlineSig noExt happy_var_3 + ( ams ((sLL happy_var_1 happy_var_4 $ SigD noExtField (InlineSig noExtField happy_var_3 (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) (snd happy_var_2))))) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]))}}}}) @@ -8425,7 +8425,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 (SigD noExt (SCCFunSig noExt (getSCC_PRAGs happy_var_1) happy_var_2 Nothing))) + ( ams (sLL happy_var_1 happy_var_3 (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs happy_var_1) happy_var_2 Nothing))) [mo happy_var_1, mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8442,7 +8442,7 @@ case happyOutTok happy_x_4 of { happy_var_4 -> ( do { scc <- getSCC happy_var_3 ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc - ; ams (sLL happy_var_1 happy_var_4 (SigD noExt (SCCFunSig noExt (getSCC_PRAGs happy_var_1) happy_var_2 (Just ( sL1 happy_var_3 str_lit))))) + ; ams (sLL happy_var_1 happy_var_4 (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs happy_var_1) happy_var_2 (Just ( sL1 happy_var_3 str_lit))))) [mo happy_var_1, mc happy_var_4] })}}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8464,7 +8464,7 @@ ( ams ( let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) (NoUserInline, FunLike) (snd happy_var_2) - in sLL happy_var_1 happy_var_6 $ SigD noExt (SpecSig noExt happy_var_3 (fromOL happy_var_5) inl_prag)) + in sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig noExtField happy_var_3 (fromOL happy_var_5) inl_prag)) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8483,7 +8483,7 @@ case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut150 happy_x_5 of { (HappyWrap150 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> - ( ams (sLL happy_var_1 happy_var_6 $ SigD noExt (SpecSig noExt happy_var_3 (fromOL happy_var_5) + ( ams (sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig noExtField happy_var_3 (fromOL happy_var_5) (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) (getSPEC_INLINE happy_var_1) (snd happy_var_2)))) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) @@ -8501,7 +8501,7 @@ case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ams (sLL happy_var_1 happy_var_4 - $ SigD noExt (SpecInstSig noExt (getSPEC_PRAGs happy_var_1) happy_var_3)) + $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs happy_var_1) happy_var_3)) [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4])}}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8514,7 +8514,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut264 happy_x_2 of { (HappyWrap264 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( ams (sLL happy_var_1 happy_var_3 $ SigD noExt (MinimalSig noExt (getMINIMAL_PRAGs happy_var_1) happy_var_2)) + ( ams (sLL happy_var_1 happy_var_3 $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs happy_var_1) happy_var_2)) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn203 r)) @@ -8611,7 +8611,7 @@ ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ - ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_1 happy_var_3 + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_1 happy_var_3 HsFirstOrderApp True) [mu Annlarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn207 r)) @@ -8628,7 +8628,7 @@ ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ - ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_3 happy_var_1 + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_3 happy_var_1 HsFirstOrderApp False) [mu Annrarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn207 r)) @@ -8645,7 +8645,7 @@ ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ - ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_1 happy_var_3 + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_1 happy_var_3 HsHigherOrderApp True) [mu AnnLarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn207 r)) @@ -8662,7 +8662,7 @@ ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ - ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_3 happy_var_1 + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_3 happy_var_1 HsHigherOrderApp False) [mu AnnRarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn207 r)) @@ -8749,7 +8749,7 @@ case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_2 $ HsTickPragma noExt (snd $ fst $ fst $ unLoc happy_var_1) + ams (sLL happy_var_1 happy_var_2 $ HsTickPragma noExtField (snd $ fst $ fst $ unLoc happy_var_1) (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) (fst $ fst $ fst $ unLoc happy_var_1))}}) ) (\r -> happyReturn (happyIn210 r)) @@ -8767,7 +8767,7 @@ case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_4 $ HsCoreAnn noExt (getCORE_PRAGs happy_var_1) (getStringLiteral happy_var_2) happy_var_4) + ams (sLL happy_var_1 happy_var_4 $ HsCoreAnn noExtField (getCORE_PRAGs happy_var_1) (getStringLiteral happy_var_2) happy_var_4) [mo happy_var_1,mj AnnVal happy_var_2 ,mc happy_var_3])}}}}) ) (\r -> happyReturn (happyIn210 r)) @@ -8797,7 +8797,7 @@ case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_2 $ HsSCC noExt (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) + ams (sLL happy_var_1 happy_var_2 $ HsSCC noExtField (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) (fst $ fst $ unLoc happy_var_1))}}) ) (\r -> happyReturn (happyIn211 r)) @@ -8916,7 +8916,7 @@ ( runECP_P happy_var_1 >>= \ happy_var_1 -> runPV (checkExpBlockArguments happy_var_1) >>= \_ -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsAppType noExt happy_var_1 (mkHsWildCardBndrs happy_var_3)) + ams (sLL happy_var_1 happy_var_3 $ HsAppType noExtField happy_var_1 (mkHsWildCardBndrs happy_var_3)) [mj AnnAt happy_var_2])}}}) ) (\r -> happyReturn (happyIn215 r)) @@ -8929,7 +8929,7 @@ case happyOut216 happy_x_2 of { (HappyWrap216 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_2 $ HsStatic noExt happy_var_2) + ams (sLL happy_var_1 happy_var_2 $ HsStatic noExtField happy_var_2) [mj AnnStatic happy_var_1])}}) ) (\r -> happyReturn (happyIn215 r)) @@ -8984,7 +8984,7 @@ (ECP $ runECP_PV happy_var_5 >>= \ happy_var_5 -> amms (mkHsLamPV (comb2 happy_var_1 happy_var_5) (mkMatchGroup FromSource - [sLL happy_var_1 happy_var_5 $ Match { m_ext = noExt + [sLL happy_var_1 happy_var_5 $ Match { m_ext = noExtField , m_ctxt = LambdaExpr , m_pats = happy_var_2:happy_var_3 , m_grhss = unguardedGRHSs happy_var_5 }])) @@ -9021,7 +9021,7 @@ case happyOut238 happy_x_3 of { (HappyWrap238 happy_var_3) -> ( runPV happy_var_3 >>= \ happy_var_3 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsLamCase noExt + ams (sLL happy_var_1 happy_var_3 $ HsLamCase noExtField (mkMatchGroup FromSource (snd $ unLoc happy_var_3))) (mj AnnLam happy_var_1:mj AnnCase happy_var_2:(fst $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn216 r)) @@ -9065,7 +9065,7 @@ case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> ( hintMultiWayIf (getLoc happy_var_1) >>= \_ -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_2 $ HsMultiIf noExt + ams (sLL happy_var_1 happy_var_2 $ HsMultiIf noExtField (reverse $ snd $ unLoc happy_var_2)) (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)))}}) ) (\r -> happyReturn (happyIn216 r)) @@ -9131,7 +9131,7 @@ ( (checkPattern <=< runECP_P) happy_var_2 >>= \ p -> runECP_P happy_var_4 >>= \ happy_var_4@cmd -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_4 $ HsProc noExt p (sLL happy_var_1 happy_var_4 $ HsCmdTop noExt cmd)) + ams (sLL happy_var_1 happy_var_4 $ HsProc noExtField p (sLL happy_var_1 happy_var_4 $ HsCmdTop noExtField cmd)) -- TODO: is LL right here? [mj AnnProc happy_var_1,mu AnnRarrow happy_var_3])}}}}) ) (\r -> happyReturn (happyIn216 r)) @@ -9192,7 +9192,7 @@ happyReduction_537 happy_x_1 = case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> happyIn218 - (ecpFromExp $ sL1 happy_var_1 (HsIPVar noExt $! unLoc happy_var_1) + (ecpFromExp $ sL1 happy_var_1 (HsIPVar noExtField $! unLoc happy_var_1) )} happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9200,7 +9200,7 @@ happyReduction_538 happy_x_1 = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> happyIn218 - (ecpFromExp $ sL1 happy_var_1 (HsOverLabel noExt Nothing $! unLoc happy_var_1) + (ecpFromExp $ sL1 happy_var_1 (HsOverLabel noExtField Nothing $! unLoc happy_var_1) )} happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9319,7 +9319,7 @@ happyReduction_549 happy_x_1 = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> happyIn218 - (ecpFromExp $ mapLoc (HsSpliceE noExt) happy_var_1 + (ecpFromExp $ mapLoc (HsSpliceE noExtField) happy_var_1 )} happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9329,7 +9329,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> - ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) + ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9339,7 +9339,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> - ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) + ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9349,7 +9349,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut297 happy_x_2 of { (HappyWrap297 happy_var_2) -> - ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) + ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9359,7 +9359,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut280 happy_x_2 of { (HappyWrap280 happy_var_2) -> - ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) + ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9381,7 +9381,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (ExpBr noExt happy_var_2)) + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (ExpBr noExtField happy_var_2)) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1, mu AnnCloseQ happy_var_3] else [mu AnnOpenEQ happy_var_1,mu AnnCloseQ happy_var_3]))}}}) ) (\r -> happyReturn (happyIn218 r)) @@ -9397,7 +9397,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (TExpBr noExt happy_var_2)) + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (TExpBr noExtField happy_var_2)) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1,mc happy_var_3] else [mo happy_var_1,mc happy_var_3]))}}}) ) (\r -> happyReturn (happyIn218 r)) @@ -9411,7 +9411,7 @@ case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (TypBr noExt happy_var_2)) [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (TypBr noExtField happy_var_2)) [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9425,7 +9425,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> ( (checkPattern <=< runECP_P) happy_var_2 >>= \p -> fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (PatBr noExt p)) + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (PatBr noExtField p)) [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) ) (\r -> happyReturn (happyIn218 r)) @@ -9439,7 +9439,7 @@ case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( fmap ecpFromExp $ - ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (DecBrL noExt (snd happy_var_2))) + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (DecBrL noExtField (snd happy_var_2))) (mo happy_var_1:mu AnnCloseQ happy_var_3:fst happy_var_2))}}}) ) (\r -> happyReturn (happyIn218 r)) @@ -9464,7 +9464,7 @@ case happyOutTok happy_x_4 of { happy_var_4 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromCmd $ - ams (sLL happy_var_1 happy_var_4 $ HsCmdArrForm noExt happy_var_2 Prefix + ams (sLL happy_var_1 happy_var_4 $ HsCmdArrForm noExtField happy_var_2 Prefix Nothing (reverse happy_var_3)) [mu AnnOpenB happy_var_1,mu AnnCloseB happy_var_4])}}}}) ) (\r -> happyReturn (happyIn218 r)) @@ -9474,7 +9474,7 @@ happyReduction_562 happy_x_1 = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> happyIn219 - (mapLoc (HsSpliceE noExt) happy_var_1 + (mapLoc (HsSpliceE noExtField) happy_var_1 )} happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9482,7 +9482,7 @@ happyReduction_563 happy_x_1 = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> happyIn219 - (mapLoc (HsSpliceE noExt) happy_var_1 + (mapLoc (HsSpliceE noExtField) happy_var_1 )} happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9491,7 +9491,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 $ mkUntypedSplice HasDollar - (sL1 happy_var_1 $ HsVar noExt (sL1 happy_var_1 (mkUnqual varName + (sL1 happy_var_1 $ HsVar noExtField (sL1 happy_var_1 (mkUnqual varName (getTH_ID_SPLICE happy_var_1))))) [mj AnnThIdSplice happy_var_1])}) ) (\r -> happyReturn (happyIn220 r)) @@ -9516,7 +9516,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 $ mkTypedSplice HasDollar - (sL1 happy_var_1 $ HsVar noExt (sL1 happy_var_1 (mkUnqual varName + (sL1 happy_var_1 $ HsVar noExtField (sL1 happy_var_1 (mkUnqual varName (getTH_ID_TY_SPLICE happy_var_1))))) [mj AnnThIdTySplice happy_var_1])}) ) (\r -> happyReturn (happyIn221 r)) @@ -9557,7 +9557,7 @@ happyRest) tk = happyThen ((case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> ( runECP_P happy_var_1 >>= \ cmd -> - return (sL1 cmd $ HsCmdTop noExt cmd))}) + return (sL1 cmd $ HsCmdTop noExtField cmd))}) ) (\r -> happyReturn (happyIn223 r)) happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9617,7 +9617,7 @@ ( runECP_P happy_var_1 >>= \ happy_var_1 -> runPV happy_var_2 >>= \ happy_var_2 -> return $ ecpFromExp $ - sLL happy_var_1 happy_var_2 $ SectionL noExt happy_var_1 happy_var_2)}}) + sLL happy_var_1 happy_var_2 $ SectionL noExtField happy_var_1 happy_var_2)}}) ) (\r -> happyReturn (happyIn226 r)) happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -9767,7 +9767,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> happyIn230 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> - ams (cL loc $ ArithSeq noExt Nothing (From happy_var_1)) + ams (cL loc $ ArithSeq noExtField Nothing (From happy_var_1)) [mj AnnDotdot happy_var_2] >>= ecpFromExp' )}} @@ -9787,7 +9787,7 @@ (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> - ams (cL loc $ ArithSeq noExt Nothing (FromThen happy_var_1 happy_var_3)) + ams (cL loc $ ArithSeq noExtField Nothing (FromThen happy_var_1 happy_var_3)) [mj AnnComma happy_var_2,mj AnnDotdot happy_var_4] >>= ecpFromExp' ) `HappyStk` happyRest}}}} @@ -9803,7 +9803,7 @@ happyIn230 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> - ams (cL loc $ ArithSeq noExt Nothing (FromTo happy_var_1 happy_var_3)) + ams (cL loc $ ArithSeq noExtField Nothing (FromTo happy_var_1 happy_var_3)) [mj AnnDotdot happy_var_2] >>= ecpFromExp' )}}} @@ -9826,7 +9826,7 @@ runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> runECP_PV happy_var_5 >>= \ happy_var_5 -> - ams (cL loc $ ArithSeq noExt Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5)) + ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5)) [mj AnnComma happy_var_2,mj AnnDotdot happy_var_4] >>= ecpFromExp' ) `HappyStk` happyRest}}}}} @@ -9889,7 +9889,7 @@ -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL1 happy_var_1 [sL1 happy_var_1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr | + qss -> sL1 happy_var_1 [sL1 happy_var_1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | qs <- qss] noExpr noSyntaxExpr] -- We actually found some actual parallel lists so @@ -10176,7 +10176,7 @@ case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> happyIn241 (happy_var_2 >>= \ happy_var_2 -> - ams (sLL happy_var_1 happy_var_2 (Match { m_ext = noExt + ams (sLL happy_var_1 happy_var_2 (Match { m_ext = noExtField , m_ctxt = CaseAlt , m_pats = [happy_var_1] , m_grhss = snd $ unLoc happy_var_2 })) @@ -10191,7 +10191,7 @@ case happyOut126 happy_x_2 of { (HappyWrap126 happy_var_2) -> happyIn242 (happy_var_1 >>= \alt -> - return $ sLL alt happy_var_2 (fst $ unLoc happy_var_2, GRHSs noExt (unLoc alt) (snd $ unLoc happy_var_2)) + return $ sLL alt happy_var_2 (fst $ unLoc happy_var_2, GRHSs noExtField (unLoc alt) (snd $ unLoc happy_var_2)) )}} happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -10271,7 +10271,7 @@ case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> happyIn246 (runECP_PV happy_var_4 >>= \ happy_var_4 -> - ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExt (unLoc happy_var_2) happy_var_4) + ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExtField (unLoc happy_var_2) happy_var_4) [mj AnnVbar happy_var_1,mu AnnRarrow happy_var_3] ) `HappyStk` happyRest}}}} @@ -10502,7 +10502,7 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> happyIn256 - (ams (sLL happy_var_1 happy_var_2 $ LetStmt noExt (snd $ unLoc happy_var_2)) + (ams (sLL happy_var_1 happy_var_2 $ LetStmt noExtField (snd $ unLoc happy_var_2)) (mj AnnLet happy_var_1:(fst $ unLoc happy_var_2)) )}} @@ -10618,7 +10618,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut207 happy_x_3 of { (HappyWrap207 happy_var_3) -> ( runECP_P happy_var_3 >>= \ happy_var_3 -> - ams (sLL happy_var_1 happy_var_3 (IPBind noExt (Left happy_var_1) happy_var_3)) + ams (sLL happy_var_1 happy_var_3 (IPBind noExtField (Left happy_var_1) happy_var_3)) [mj AnnEqual happy_var_2])}}}) ) (\r -> happyReturn (happyIn261 r)) @@ -11184,7 +11184,7 @@ happyReduction_716 happy_x_1 = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> happyIn286 - (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1) + (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1) )} happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -11194,7 +11194,7 @@ = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> happyIn286 - (sLL happy_var_1 happy_var_2 (HsDocTy noExt (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1)) happy_var_2) + (sLL happy_var_1 happy_var_2 (HsDocTy noExtField (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1)) happy_var_2) )}} happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -11996,7 +11996,7 @@ happyReduction_811 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn315 - (sL1 happy_var_1 $ HsFloatPrim noExt $ getPRIMFLOAT happy_var_1 + (sL1 happy_var_1 $ HsFloatPrim noExtField $ getPRIMFLOAT happy_var_1 )} happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -12004,7 +12004,7 @@ happyReduction_812 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn315 - (sL1 happy_var_1 $ HsDoublePrim noExt $ getPRIMDOUBLE happy_var_1 + (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE happy_var_1 )} happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -12617,10 +12617,10 @@ -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword itself mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn -mj a l s = addAnnotation s a (gl l) +mj a l = AddAnn a (gl l) mjL :: AnnKeywordId -> SrcSpan -> AddAnn -mjL a l s = addAnnotation s a l +mjL = AddAnn @@ -12628,7 +12628,7 @@ -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(dL->L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) +mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation @@ -12744,181 +12744,7 @@ {-# LINE 19 "" #-} -{-# LINE 1 "/var/folders/kc/bjk2hzwx6bv07jz_s80wjh7w0000gn/T/ghc91361_0/ghc_2.h" #-} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc17116_0/ghc_2.h" #-} diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -0,0 +1,21 @@ +module GHC.Version where + +import Prelude -- See Note [Why do we import Prelude here?] + +cProjectGitCommitId :: String +cProjectGitCommitId = "6e5dfcd2886d7523cfa059a64b343b22c5da4e97" + +cProjectVersion :: String +cProjectVersion = "8.9.0.20190804" + +cProjectVersionInt :: String +cProjectVersionInt = "809" + +cProjectPatchLevel :: String +cProjectPatchLevel = "020190804" + +cProjectPatchLevel1 :: String +cProjectPatchLevel1 = "0" + +cProjectPatchLevel2 :: String +cProjectPatchLevel2 = "20190804" diff --git a/ghc-lib/stage1/compiler/build/Config.hs b/ghc-lib/stage1/compiler/build/Config.hs --- a/ghc-lib/stage1/compiler/build/Config.hs +++ b/ghc-lib/stage1/compiler/build/Config.hs @@ -1,30 +1,30 @@ {-# LANGUAGE CPP #-} -module Config where +module Config + ( module GHC.Version + , cBuildPlatformString + , cHostPlatformString + , cProjectName + , cBooterVersion + , cStage + ) where import GhcPrelude +import GHC.Version + #include "ghc_boot_platform.h" cBuildPlatformString :: String cBuildPlatformString = BuildPlatform_NAME + cHostPlatformString :: String cHostPlatformString = HostPlatform_NAME cProjectName :: String cProjectName = "The Glorious Glasgow Haskell Compilation System" -cProjectGitCommitId :: String -cProjectGitCommitId = "a25f6f55eaca0d3ec36afb574d5fa9326ea09d55" -cProjectVersion :: String -cProjectVersion = "8.9.0.20190703" -cProjectVersionInt :: String -cProjectVersionInt = "809" -cProjectPatchLevel :: String -cProjectPatchLevel = "020190703" -cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "0" -cProjectPatchLevel2 :: String -cProjectPatchLevel2 = "20190703" + cBooterVersion :: String cBooterVersion = "8.6.5" + cStage :: String cStage = show (STAGE :: Int) diff --git a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h --- a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h +++ b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h @@ -6,28 +6,20 @@ #define x86_64_apple_darwin_BUILD 1 #define x86_64_apple_darwin_HOST 1 -#define x86_64_apple_darwin_TARGET 1 #define x86_64_BUILD_ARCH 1 #define x86_64_HOST_ARCH 1 -#define x86_64_TARGET_ARCH 1 #define BUILD_ARCH "x86_64" #define HOST_ARCH "x86_64" -#define TARGET_ARCH "x86_64" -#define LLVM_TARGET "x86_64-apple-darwin" #define darwin_BUILD_OS 1 #define darwin_HOST_OS 1 -#define darwin_TARGET_OS 1 #define BUILD_OS "darwin" #define HOST_OS "darwin" -#define TARGET_OS "darwin" #define apple_BUILD_VENDOR 1 #define apple_HOST_VENDOR 1 -#define apple_TARGET_VENDOR 1 #define BUILD_VENDOR "apple" #define HOST_VENDOR "apple" -#define TARGET_VENDOR "apple" #endif /* __PLATFORM_H__ */ diff --git a/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl @@ -541,7 +541,6 @@ | TraceEventOp | TraceEventBinaryOp | TraceMarkerOp - | GetThreadAllocationCounter | SetThreadAllocationCounter | VecBroadcastOp PrimOpVecCat Length Width | VecPackOp PrimOpVecCat Length Width diff --git a/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl --- a/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl +++ b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl @@ -213,7 +213,6 @@ primOpHasSideEffects TraceEventOp = True primOpHasSideEffects TraceEventBinaryOp = True primOpHasSideEffects TraceMarkerOp = True -primOpHasSideEffects GetThreadAllocationCounter = True primOpHasSideEffects SetThreadAllocationCounter = True primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True diff --git a/ghc-lib/stage1/compiler/build/primop-list.hs-incl b/ghc-lib/stage1/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage1/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage1/compiler/build/primop-list.hs-incl @@ -540,7 +540,6 @@ , TraceEventOp , TraceEventBinaryOp , TraceMarkerOp - , GetThreadAllocationCounter , SetThreadAllocationCounter , (VecBroadcastOp IntVec 16 W8) , (VecBroadcastOp IntVec 8 W16) diff --git a/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl --- a/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl +++ b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl @@ -97,6 +97,5 @@ primOpOutOfLine TraceEventOp = True primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True -primOpOutOfLine GetThreadAllocationCounter = True primOpOutOfLine SetThreadAllocationCounter = True primOpOutOfLine _ = False diff --git a/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl @@ -540,7 +540,6 @@ primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [intPrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [intPrimTy] (int16X8PrimTy) diff --git a/ghc-lib/stage1/compiler/build/primop-tag.hs-incl b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage1/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl @@ -1,1205 +1,1204 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1202 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 1 -primOpTag CharGeOp = 2 -primOpTag CharEqOp = 3 -primOpTag CharNeOp = 4 -primOpTag CharLtOp = 5 -primOpTag CharLeOp = 6 -primOpTag OrdOp = 7 -primOpTag IntAddOp = 8 -primOpTag IntSubOp = 9 -primOpTag IntMulOp = 10 -primOpTag IntMulMayOfloOp = 11 -primOpTag IntQuotOp = 12 -primOpTag IntRemOp = 13 -primOpTag IntQuotRemOp = 14 -primOpTag AndIOp = 15 -primOpTag OrIOp = 16 -primOpTag XorIOp = 17 -primOpTag NotIOp = 18 -primOpTag IntNegOp = 19 -primOpTag IntAddCOp = 20 -primOpTag IntSubCOp = 21 -primOpTag IntGtOp = 22 -primOpTag IntGeOp = 23 -primOpTag IntEqOp = 24 -primOpTag IntNeOp = 25 -primOpTag IntLtOp = 26 -primOpTag IntLeOp = 27 -primOpTag ChrOp = 28 -primOpTag Int2WordOp = 29 -primOpTag Int2FloatOp = 30 -primOpTag Int2DoubleOp = 31 -primOpTag Word2FloatOp = 32 -primOpTag Word2DoubleOp = 33 -primOpTag ISllOp = 34 -primOpTag ISraOp = 35 -primOpTag ISrlOp = 36 -primOpTag Int8Extend = 37 -primOpTag Int8Narrow = 38 -primOpTag Int8NegOp = 39 -primOpTag Int8AddOp = 40 -primOpTag Int8SubOp = 41 -primOpTag Int8MulOp = 42 -primOpTag Int8QuotOp = 43 -primOpTag Int8RemOp = 44 -primOpTag Int8QuotRemOp = 45 -primOpTag Int8EqOp = 46 -primOpTag Int8GeOp = 47 -primOpTag Int8GtOp = 48 -primOpTag Int8LeOp = 49 -primOpTag Int8LtOp = 50 -primOpTag Int8NeOp = 51 -primOpTag Word8Extend = 52 -primOpTag Word8Narrow = 53 -primOpTag Word8NotOp = 54 -primOpTag Word8AddOp = 55 -primOpTag Word8SubOp = 56 -primOpTag Word8MulOp = 57 -primOpTag Word8QuotOp = 58 -primOpTag Word8RemOp = 59 -primOpTag Word8QuotRemOp = 60 -primOpTag Word8EqOp = 61 -primOpTag Word8GeOp = 62 -primOpTag Word8GtOp = 63 -primOpTag Word8LeOp = 64 -primOpTag Word8LtOp = 65 -primOpTag Word8NeOp = 66 -primOpTag Int16Extend = 67 -primOpTag Int16Narrow = 68 -primOpTag Int16NegOp = 69 -primOpTag Int16AddOp = 70 -primOpTag Int16SubOp = 71 -primOpTag Int16MulOp = 72 -primOpTag Int16QuotOp = 73 -primOpTag Int16RemOp = 74 -primOpTag Int16QuotRemOp = 75 -primOpTag Int16EqOp = 76 -primOpTag Int16GeOp = 77 -primOpTag Int16GtOp = 78 -primOpTag Int16LeOp = 79 -primOpTag Int16LtOp = 80 -primOpTag Int16NeOp = 81 -primOpTag Word16Extend = 82 -primOpTag Word16Narrow = 83 -primOpTag Word16NotOp = 84 -primOpTag Word16AddOp = 85 -primOpTag Word16SubOp = 86 -primOpTag Word16MulOp = 87 -primOpTag Word16QuotOp = 88 -primOpTag Word16RemOp = 89 -primOpTag Word16QuotRemOp = 90 -primOpTag Word16EqOp = 91 -primOpTag Word16GeOp = 92 -primOpTag Word16GtOp = 93 -primOpTag Word16LeOp = 94 -primOpTag Word16LtOp = 95 -primOpTag Word16NeOp = 96 -primOpTag WordAddOp = 97 -primOpTag WordAddCOp = 98 -primOpTag WordSubCOp = 99 -primOpTag WordAdd2Op = 100 -primOpTag WordSubOp = 101 -primOpTag WordMulOp = 102 -primOpTag WordMul2Op = 103 -primOpTag WordQuotOp = 104 -primOpTag WordRemOp = 105 -primOpTag WordQuotRemOp = 106 -primOpTag WordQuotRem2Op = 107 -primOpTag AndOp = 108 -primOpTag OrOp = 109 -primOpTag XorOp = 110 -primOpTag NotOp = 111 -primOpTag SllOp = 112 -primOpTag SrlOp = 113 -primOpTag Word2IntOp = 114 -primOpTag WordGtOp = 115 -primOpTag WordGeOp = 116 -primOpTag WordEqOp = 117 -primOpTag WordNeOp = 118 -primOpTag WordLtOp = 119 -primOpTag WordLeOp = 120 -primOpTag PopCnt8Op = 121 -primOpTag PopCnt16Op = 122 -primOpTag PopCnt32Op = 123 -primOpTag PopCnt64Op = 124 -primOpTag PopCntOp = 125 -primOpTag Pdep8Op = 126 -primOpTag Pdep16Op = 127 -primOpTag Pdep32Op = 128 -primOpTag Pdep64Op = 129 -primOpTag PdepOp = 130 -primOpTag Pext8Op = 131 -primOpTag Pext16Op = 132 -primOpTag Pext32Op = 133 -primOpTag Pext64Op = 134 -primOpTag PextOp = 135 -primOpTag Clz8Op = 136 -primOpTag Clz16Op = 137 -primOpTag Clz32Op = 138 -primOpTag Clz64Op = 139 -primOpTag ClzOp = 140 -primOpTag Ctz8Op = 141 -primOpTag Ctz16Op = 142 -primOpTag Ctz32Op = 143 -primOpTag Ctz64Op = 144 -primOpTag CtzOp = 145 -primOpTag BSwap16Op = 146 -primOpTag BSwap32Op = 147 -primOpTag BSwap64Op = 148 -primOpTag BSwapOp = 149 -primOpTag BRev8Op = 150 -primOpTag BRev16Op = 151 -primOpTag BRev32Op = 152 -primOpTag BRev64Op = 153 -primOpTag BRevOp = 154 -primOpTag Narrow8IntOp = 155 -primOpTag Narrow16IntOp = 156 -primOpTag Narrow32IntOp = 157 -primOpTag Narrow8WordOp = 158 -primOpTag Narrow16WordOp = 159 -primOpTag Narrow32WordOp = 160 -primOpTag DoubleGtOp = 161 -primOpTag DoubleGeOp = 162 -primOpTag DoubleEqOp = 163 -primOpTag DoubleNeOp = 164 -primOpTag DoubleLtOp = 165 -primOpTag DoubleLeOp = 166 -primOpTag DoubleAddOp = 167 -primOpTag DoubleSubOp = 168 -primOpTag DoubleMulOp = 169 -primOpTag DoubleDivOp = 170 -primOpTag DoubleNegOp = 171 -primOpTag DoubleFabsOp = 172 -primOpTag Double2IntOp = 173 -primOpTag Double2FloatOp = 174 -primOpTag DoubleExpOp = 175 -primOpTag DoubleExpM1Op = 176 -primOpTag DoubleLogOp = 177 -primOpTag DoubleLog1POp = 178 -primOpTag DoubleSqrtOp = 179 -primOpTag DoubleSinOp = 180 -primOpTag DoubleCosOp = 181 -primOpTag DoubleTanOp = 182 -primOpTag DoubleAsinOp = 183 -primOpTag DoubleAcosOp = 184 -primOpTag DoubleAtanOp = 185 -primOpTag DoubleSinhOp = 186 -primOpTag DoubleCoshOp = 187 -primOpTag DoubleTanhOp = 188 -primOpTag DoubleAsinhOp = 189 -primOpTag DoubleAcoshOp = 190 -primOpTag DoubleAtanhOp = 191 -primOpTag DoublePowerOp = 192 -primOpTag DoubleDecode_2IntOp = 193 -primOpTag DoubleDecode_Int64Op = 194 -primOpTag FloatGtOp = 195 -primOpTag FloatGeOp = 196 -primOpTag FloatEqOp = 197 -primOpTag FloatNeOp = 198 -primOpTag FloatLtOp = 199 -primOpTag FloatLeOp = 200 -primOpTag FloatAddOp = 201 -primOpTag FloatSubOp = 202 -primOpTag FloatMulOp = 203 -primOpTag FloatDivOp = 204 -primOpTag FloatNegOp = 205 -primOpTag FloatFabsOp = 206 -primOpTag Float2IntOp = 207 -primOpTag FloatExpOp = 208 -primOpTag FloatExpM1Op = 209 -primOpTag FloatLogOp = 210 -primOpTag FloatLog1POp = 211 -primOpTag FloatSqrtOp = 212 -primOpTag FloatSinOp = 213 -primOpTag FloatCosOp = 214 -primOpTag FloatTanOp = 215 -primOpTag FloatAsinOp = 216 -primOpTag FloatAcosOp = 217 -primOpTag FloatAtanOp = 218 -primOpTag FloatSinhOp = 219 -primOpTag FloatCoshOp = 220 -primOpTag FloatTanhOp = 221 -primOpTag FloatAsinhOp = 222 -primOpTag FloatAcoshOp = 223 -primOpTag FloatAtanhOp = 224 -primOpTag FloatPowerOp = 225 -primOpTag Float2DoubleOp = 226 -primOpTag FloatDecode_IntOp = 227 -primOpTag NewArrayOp = 228 -primOpTag SameMutableArrayOp = 229 -primOpTag ReadArrayOp = 230 -primOpTag WriteArrayOp = 231 -primOpTag SizeofArrayOp = 232 -primOpTag SizeofMutableArrayOp = 233 -primOpTag IndexArrayOp = 234 -primOpTag UnsafeFreezeArrayOp = 235 -primOpTag UnsafeThawArrayOp = 236 -primOpTag CopyArrayOp = 237 -primOpTag CopyMutableArrayOp = 238 -primOpTag CloneArrayOp = 239 -primOpTag CloneMutableArrayOp = 240 -primOpTag FreezeArrayOp = 241 -primOpTag ThawArrayOp = 242 -primOpTag CasArrayOp = 243 -primOpTag NewSmallArrayOp = 244 -primOpTag SameSmallMutableArrayOp = 245 -primOpTag ReadSmallArrayOp = 246 -primOpTag WriteSmallArrayOp = 247 -primOpTag SizeofSmallArrayOp = 248 -primOpTag SizeofSmallMutableArrayOp = 249 -primOpTag IndexSmallArrayOp = 250 -primOpTag UnsafeFreezeSmallArrayOp = 251 -primOpTag UnsafeThawSmallArrayOp = 252 -primOpTag CopySmallArrayOp = 253 -primOpTag CopySmallMutableArrayOp = 254 -primOpTag CloneSmallArrayOp = 255 -primOpTag CloneSmallMutableArrayOp = 256 -primOpTag FreezeSmallArrayOp = 257 -primOpTag ThawSmallArrayOp = 258 -primOpTag CasSmallArrayOp = 259 -primOpTag NewByteArrayOp_Char = 260 -primOpTag NewPinnedByteArrayOp_Char = 261 -primOpTag NewAlignedPinnedByteArrayOp_Char = 262 -primOpTag MutableByteArrayIsPinnedOp = 263 -primOpTag ByteArrayIsPinnedOp = 264 -primOpTag ByteArrayContents_Char = 265 -primOpTag SameMutableByteArrayOp = 266 -primOpTag ShrinkMutableByteArrayOp_Char = 267 -primOpTag ResizeMutableByteArrayOp_Char = 268 -primOpTag UnsafeFreezeByteArrayOp = 269 -primOpTag SizeofByteArrayOp = 270 -primOpTag SizeofMutableByteArrayOp = 271 -primOpTag GetSizeofMutableByteArrayOp = 272 -primOpTag IndexByteArrayOp_Char = 273 -primOpTag IndexByteArrayOp_WideChar = 274 -primOpTag IndexByteArrayOp_Int = 275 -primOpTag IndexByteArrayOp_Word = 276 -primOpTag IndexByteArrayOp_Addr = 277 -primOpTag IndexByteArrayOp_Float = 278 -primOpTag IndexByteArrayOp_Double = 279 -primOpTag IndexByteArrayOp_StablePtr = 280 -primOpTag IndexByteArrayOp_Int8 = 281 -primOpTag IndexByteArrayOp_Int16 = 282 -primOpTag IndexByteArrayOp_Int32 = 283 -primOpTag IndexByteArrayOp_Int64 = 284 -primOpTag IndexByteArrayOp_Word8 = 285 -primOpTag IndexByteArrayOp_Word16 = 286 -primOpTag IndexByteArrayOp_Word32 = 287 -primOpTag IndexByteArrayOp_Word64 = 288 -primOpTag IndexByteArrayOp_Word8AsChar = 289 -primOpTag IndexByteArrayOp_Word8AsWideChar = 290 -primOpTag IndexByteArrayOp_Word8AsAddr = 291 -primOpTag IndexByteArrayOp_Word8AsFloat = 292 -primOpTag IndexByteArrayOp_Word8AsDouble = 293 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 294 -primOpTag IndexByteArrayOp_Word8AsInt16 = 295 -primOpTag IndexByteArrayOp_Word8AsInt32 = 296 -primOpTag IndexByteArrayOp_Word8AsInt64 = 297 -primOpTag IndexByteArrayOp_Word8AsInt = 298 -primOpTag IndexByteArrayOp_Word8AsWord16 = 299 -primOpTag IndexByteArrayOp_Word8AsWord32 = 300 -primOpTag IndexByteArrayOp_Word8AsWord64 = 301 -primOpTag IndexByteArrayOp_Word8AsWord = 302 -primOpTag ReadByteArrayOp_Char = 303 -primOpTag ReadByteArrayOp_WideChar = 304 -primOpTag ReadByteArrayOp_Int = 305 -primOpTag ReadByteArrayOp_Word = 306 -primOpTag ReadByteArrayOp_Addr = 307 -primOpTag ReadByteArrayOp_Float = 308 -primOpTag ReadByteArrayOp_Double = 309 -primOpTag ReadByteArrayOp_StablePtr = 310 -primOpTag ReadByteArrayOp_Int8 = 311 -primOpTag ReadByteArrayOp_Int16 = 312 -primOpTag ReadByteArrayOp_Int32 = 313 -primOpTag ReadByteArrayOp_Int64 = 314 -primOpTag ReadByteArrayOp_Word8 = 315 -primOpTag ReadByteArrayOp_Word16 = 316 -primOpTag ReadByteArrayOp_Word32 = 317 -primOpTag ReadByteArrayOp_Word64 = 318 -primOpTag ReadByteArrayOp_Word8AsChar = 319 -primOpTag ReadByteArrayOp_Word8AsWideChar = 320 -primOpTag ReadByteArrayOp_Word8AsAddr = 321 -primOpTag ReadByteArrayOp_Word8AsFloat = 322 -primOpTag ReadByteArrayOp_Word8AsDouble = 323 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 324 -primOpTag ReadByteArrayOp_Word8AsInt16 = 325 -primOpTag ReadByteArrayOp_Word8AsInt32 = 326 -primOpTag ReadByteArrayOp_Word8AsInt64 = 327 -primOpTag ReadByteArrayOp_Word8AsInt = 328 -primOpTag ReadByteArrayOp_Word8AsWord16 = 329 -primOpTag ReadByteArrayOp_Word8AsWord32 = 330 -primOpTag ReadByteArrayOp_Word8AsWord64 = 331 -primOpTag ReadByteArrayOp_Word8AsWord = 332 -primOpTag WriteByteArrayOp_Char = 333 -primOpTag WriteByteArrayOp_WideChar = 334 -primOpTag WriteByteArrayOp_Int = 335 -primOpTag WriteByteArrayOp_Word = 336 -primOpTag WriteByteArrayOp_Addr = 337 -primOpTag WriteByteArrayOp_Float = 338 -primOpTag WriteByteArrayOp_Double = 339 -primOpTag WriteByteArrayOp_StablePtr = 340 -primOpTag WriteByteArrayOp_Int8 = 341 -primOpTag WriteByteArrayOp_Int16 = 342 -primOpTag WriteByteArrayOp_Int32 = 343 -primOpTag WriteByteArrayOp_Int64 = 344 -primOpTag WriteByteArrayOp_Word8 = 345 -primOpTag WriteByteArrayOp_Word16 = 346 -primOpTag WriteByteArrayOp_Word32 = 347 -primOpTag WriteByteArrayOp_Word64 = 348 -primOpTag WriteByteArrayOp_Word8AsChar = 349 -primOpTag WriteByteArrayOp_Word8AsWideChar = 350 -primOpTag WriteByteArrayOp_Word8AsAddr = 351 -primOpTag WriteByteArrayOp_Word8AsFloat = 352 -primOpTag WriteByteArrayOp_Word8AsDouble = 353 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 354 -primOpTag WriteByteArrayOp_Word8AsInt16 = 355 -primOpTag WriteByteArrayOp_Word8AsInt32 = 356 -primOpTag WriteByteArrayOp_Word8AsInt64 = 357 -primOpTag WriteByteArrayOp_Word8AsInt = 358 -primOpTag WriteByteArrayOp_Word8AsWord16 = 359 -primOpTag WriteByteArrayOp_Word8AsWord32 = 360 -primOpTag WriteByteArrayOp_Word8AsWord64 = 361 -primOpTag WriteByteArrayOp_Word8AsWord = 362 -primOpTag CompareByteArraysOp = 363 -primOpTag CopyByteArrayOp = 364 -primOpTag CopyMutableByteArrayOp = 365 -primOpTag CopyByteArrayToAddrOp = 366 -primOpTag CopyMutableByteArrayToAddrOp = 367 -primOpTag CopyAddrToByteArrayOp = 368 -primOpTag SetByteArrayOp = 369 -primOpTag AtomicReadByteArrayOp_Int = 370 -primOpTag AtomicWriteByteArrayOp_Int = 371 -primOpTag CasByteArrayOp_Int = 372 -primOpTag FetchAddByteArrayOp_Int = 373 -primOpTag FetchSubByteArrayOp_Int = 374 -primOpTag FetchAndByteArrayOp_Int = 375 -primOpTag FetchNandByteArrayOp_Int = 376 -primOpTag FetchOrByteArrayOp_Int = 377 -primOpTag FetchXorByteArrayOp_Int = 378 -primOpTag NewArrayArrayOp = 379 -primOpTag SameMutableArrayArrayOp = 380 -primOpTag UnsafeFreezeArrayArrayOp = 381 -primOpTag SizeofArrayArrayOp = 382 -primOpTag SizeofMutableArrayArrayOp = 383 -primOpTag IndexArrayArrayOp_ByteArray = 384 -primOpTag IndexArrayArrayOp_ArrayArray = 385 -primOpTag ReadArrayArrayOp_ByteArray = 386 -primOpTag ReadArrayArrayOp_MutableByteArray = 387 -primOpTag ReadArrayArrayOp_ArrayArray = 388 -primOpTag ReadArrayArrayOp_MutableArrayArray = 389 -primOpTag WriteArrayArrayOp_ByteArray = 390 -primOpTag WriteArrayArrayOp_MutableByteArray = 391 -primOpTag WriteArrayArrayOp_ArrayArray = 392 -primOpTag WriteArrayArrayOp_MutableArrayArray = 393 -primOpTag CopyArrayArrayOp = 394 -primOpTag CopyMutableArrayArrayOp = 395 -primOpTag AddrAddOp = 396 -primOpTag AddrSubOp = 397 -primOpTag AddrRemOp = 398 -primOpTag Addr2IntOp = 399 -primOpTag Int2AddrOp = 400 -primOpTag AddrGtOp = 401 -primOpTag AddrGeOp = 402 -primOpTag AddrEqOp = 403 -primOpTag AddrNeOp = 404 -primOpTag AddrLtOp = 405 -primOpTag AddrLeOp = 406 -primOpTag IndexOffAddrOp_Char = 407 -primOpTag IndexOffAddrOp_WideChar = 408 -primOpTag IndexOffAddrOp_Int = 409 -primOpTag IndexOffAddrOp_Word = 410 -primOpTag IndexOffAddrOp_Addr = 411 -primOpTag IndexOffAddrOp_Float = 412 -primOpTag IndexOffAddrOp_Double = 413 -primOpTag IndexOffAddrOp_StablePtr = 414 -primOpTag IndexOffAddrOp_Int8 = 415 -primOpTag IndexOffAddrOp_Int16 = 416 -primOpTag IndexOffAddrOp_Int32 = 417 -primOpTag IndexOffAddrOp_Int64 = 418 -primOpTag IndexOffAddrOp_Word8 = 419 -primOpTag IndexOffAddrOp_Word16 = 420 -primOpTag IndexOffAddrOp_Word32 = 421 -primOpTag IndexOffAddrOp_Word64 = 422 -primOpTag ReadOffAddrOp_Char = 423 -primOpTag ReadOffAddrOp_WideChar = 424 -primOpTag ReadOffAddrOp_Int = 425 -primOpTag ReadOffAddrOp_Word = 426 -primOpTag ReadOffAddrOp_Addr = 427 -primOpTag ReadOffAddrOp_Float = 428 -primOpTag ReadOffAddrOp_Double = 429 -primOpTag ReadOffAddrOp_StablePtr = 430 -primOpTag ReadOffAddrOp_Int8 = 431 -primOpTag ReadOffAddrOp_Int16 = 432 -primOpTag ReadOffAddrOp_Int32 = 433 -primOpTag ReadOffAddrOp_Int64 = 434 -primOpTag ReadOffAddrOp_Word8 = 435 -primOpTag ReadOffAddrOp_Word16 = 436 -primOpTag ReadOffAddrOp_Word32 = 437 -primOpTag ReadOffAddrOp_Word64 = 438 -primOpTag WriteOffAddrOp_Char = 439 -primOpTag WriteOffAddrOp_WideChar = 440 -primOpTag WriteOffAddrOp_Int = 441 -primOpTag WriteOffAddrOp_Word = 442 -primOpTag WriteOffAddrOp_Addr = 443 -primOpTag WriteOffAddrOp_Float = 444 -primOpTag WriteOffAddrOp_Double = 445 -primOpTag WriteOffAddrOp_StablePtr = 446 -primOpTag WriteOffAddrOp_Int8 = 447 -primOpTag WriteOffAddrOp_Int16 = 448 -primOpTag WriteOffAddrOp_Int32 = 449 -primOpTag WriteOffAddrOp_Int64 = 450 -primOpTag WriteOffAddrOp_Word8 = 451 -primOpTag WriteOffAddrOp_Word16 = 452 -primOpTag WriteOffAddrOp_Word32 = 453 -primOpTag WriteOffAddrOp_Word64 = 454 -primOpTag NewMutVarOp = 455 -primOpTag ReadMutVarOp = 456 -primOpTag WriteMutVarOp = 457 -primOpTag SameMutVarOp = 458 -primOpTag AtomicModifyMutVar2Op = 459 -primOpTag AtomicModifyMutVar_Op = 460 -primOpTag CasMutVarOp = 461 -primOpTag CatchOp = 462 -primOpTag RaiseOp = 463 -primOpTag RaiseIOOp = 464 -primOpTag MaskAsyncExceptionsOp = 465 -primOpTag MaskUninterruptibleOp = 466 -primOpTag UnmaskAsyncExceptionsOp = 467 -primOpTag MaskStatus = 468 -primOpTag AtomicallyOp = 469 -primOpTag RetryOp = 470 -primOpTag CatchRetryOp = 471 -primOpTag CatchSTMOp = 472 -primOpTag NewTVarOp = 473 -primOpTag ReadTVarOp = 474 -primOpTag ReadTVarIOOp = 475 -primOpTag WriteTVarOp = 476 -primOpTag SameTVarOp = 477 -primOpTag NewMVarOp = 478 -primOpTag TakeMVarOp = 479 -primOpTag TryTakeMVarOp = 480 -primOpTag PutMVarOp = 481 -primOpTag TryPutMVarOp = 482 -primOpTag ReadMVarOp = 483 -primOpTag TryReadMVarOp = 484 -primOpTag SameMVarOp = 485 -primOpTag IsEmptyMVarOp = 486 -primOpTag DelayOp = 487 -primOpTag WaitReadOp = 488 -primOpTag WaitWriteOp = 489 -primOpTag ForkOp = 490 -primOpTag ForkOnOp = 491 -primOpTag KillThreadOp = 492 -primOpTag YieldOp = 493 -primOpTag MyThreadIdOp = 494 -primOpTag LabelThreadOp = 495 -primOpTag IsCurrentThreadBoundOp = 496 -primOpTag NoDuplicateOp = 497 -primOpTag ThreadStatusOp = 498 -primOpTag MkWeakOp = 499 -primOpTag MkWeakNoFinalizerOp = 500 -primOpTag AddCFinalizerToWeakOp = 501 -primOpTag DeRefWeakOp = 502 -primOpTag FinalizeWeakOp = 503 -primOpTag TouchOp = 504 -primOpTag MakeStablePtrOp = 505 -primOpTag DeRefStablePtrOp = 506 -primOpTag EqStablePtrOp = 507 -primOpTag MakeStableNameOp = 508 -primOpTag EqStableNameOp = 509 -primOpTag StableNameToIntOp = 510 -primOpTag CompactNewOp = 511 -primOpTag CompactResizeOp = 512 -primOpTag CompactContainsOp = 513 -primOpTag CompactContainsAnyOp = 514 -primOpTag CompactGetFirstBlockOp = 515 -primOpTag CompactGetNextBlockOp = 516 -primOpTag CompactAllocateBlockOp = 517 -primOpTag CompactFixupPointersOp = 518 -primOpTag CompactAdd = 519 -primOpTag CompactAddWithSharing = 520 -primOpTag CompactSize = 521 -primOpTag ReallyUnsafePtrEqualityOp = 522 -primOpTag ParOp = 523 -primOpTag SparkOp = 524 -primOpTag SeqOp = 525 -primOpTag GetSparkOp = 526 -primOpTag NumSparks = 527 -primOpTag DataToTagOp = 528 -primOpTag TagToEnumOp = 529 -primOpTag AddrToAnyOp = 530 -primOpTag AnyToAddrOp = 531 -primOpTag MkApUpd0_Op = 532 -primOpTag NewBCOOp = 533 -primOpTag UnpackClosureOp = 534 -primOpTag ClosureSizeOp = 535 -primOpTag GetApStackValOp = 536 -primOpTag GetCCSOfOp = 537 -primOpTag GetCurrentCCSOp = 538 -primOpTag ClearCCSOp = 539 -primOpTag TraceEventOp = 540 -primOpTag TraceEventBinaryOp = 541 -primOpTag TraceMarkerOp = 542 -primOpTag GetThreadAllocationCounter = 543 -primOpTag SetThreadAllocationCounter = 544 -primOpTag (VecBroadcastOp IntVec 16 W8) = 545 -primOpTag (VecBroadcastOp IntVec 8 W16) = 546 -primOpTag (VecBroadcastOp IntVec 4 W32) = 547 -primOpTag (VecBroadcastOp IntVec 2 W64) = 548 -primOpTag (VecBroadcastOp IntVec 32 W8) = 549 -primOpTag (VecBroadcastOp IntVec 16 W16) = 550 -primOpTag (VecBroadcastOp IntVec 8 W32) = 551 -primOpTag (VecBroadcastOp IntVec 4 W64) = 552 -primOpTag (VecBroadcastOp IntVec 64 W8) = 553 -primOpTag (VecBroadcastOp IntVec 32 W16) = 554 -primOpTag (VecBroadcastOp IntVec 16 W32) = 555 -primOpTag (VecBroadcastOp IntVec 8 W64) = 556 -primOpTag (VecBroadcastOp WordVec 16 W8) = 557 -primOpTag (VecBroadcastOp WordVec 8 W16) = 558 -primOpTag (VecBroadcastOp WordVec 4 W32) = 559 -primOpTag (VecBroadcastOp WordVec 2 W64) = 560 -primOpTag (VecBroadcastOp WordVec 32 W8) = 561 -primOpTag (VecBroadcastOp WordVec 16 W16) = 562 -primOpTag (VecBroadcastOp WordVec 8 W32) = 563 -primOpTag (VecBroadcastOp WordVec 4 W64) = 564 -primOpTag (VecBroadcastOp WordVec 64 W8) = 565 -primOpTag (VecBroadcastOp WordVec 32 W16) = 566 -primOpTag (VecBroadcastOp WordVec 16 W32) = 567 -primOpTag (VecBroadcastOp WordVec 8 W64) = 568 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 569 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 570 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 571 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 572 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 573 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 574 -primOpTag (VecPackOp IntVec 16 W8) = 575 -primOpTag (VecPackOp IntVec 8 W16) = 576 -primOpTag (VecPackOp IntVec 4 W32) = 577 -primOpTag (VecPackOp IntVec 2 W64) = 578 -primOpTag (VecPackOp IntVec 32 W8) = 579 -primOpTag (VecPackOp IntVec 16 W16) = 580 -primOpTag (VecPackOp IntVec 8 W32) = 581 -primOpTag (VecPackOp IntVec 4 W64) = 582 -primOpTag (VecPackOp IntVec 64 W8) = 583 -primOpTag (VecPackOp IntVec 32 W16) = 584 -primOpTag (VecPackOp IntVec 16 W32) = 585 -primOpTag (VecPackOp IntVec 8 W64) = 586 -primOpTag (VecPackOp WordVec 16 W8) = 587 -primOpTag (VecPackOp WordVec 8 W16) = 588 -primOpTag (VecPackOp WordVec 4 W32) = 589 -primOpTag (VecPackOp WordVec 2 W64) = 590 -primOpTag (VecPackOp WordVec 32 W8) = 591 -primOpTag (VecPackOp WordVec 16 W16) = 592 -primOpTag (VecPackOp WordVec 8 W32) = 593 -primOpTag (VecPackOp WordVec 4 W64) = 594 -primOpTag (VecPackOp WordVec 64 W8) = 595 -primOpTag (VecPackOp WordVec 32 W16) = 596 -primOpTag (VecPackOp WordVec 16 W32) = 597 -primOpTag (VecPackOp WordVec 8 W64) = 598 -primOpTag (VecPackOp FloatVec 4 W32) = 599 -primOpTag (VecPackOp FloatVec 2 W64) = 600 -primOpTag (VecPackOp FloatVec 8 W32) = 601 -primOpTag (VecPackOp FloatVec 4 W64) = 602 -primOpTag (VecPackOp FloatVec 16 W32) = 603 -primOpTag (VecPackOp FloatVec 8 W64) = 604 -primOpTag (VecUnpackOp IntVec 16 W8) = 605 -primOpTag (VecUnpackOp IntVec 8 W16) = 606 -primOpTag (VecUnpackOp IntVec 4 W32) = 607 -primOpTag (VecUnpackOp IntVec 2 W64) = 608 -primOpTag (VecUnpackOp IntVec 32 W8) = 609 -primOpTag (VecUnpackOp IntVec 16 W16) = 610 -primOpTag (VecUnpackOp IntVec 8 W32) = 611 -primOpTag (VecUnpackOp IntVec 4 W64) = 612 -primOpTag (VecUnpackOp IntVec 64 W8) = 613 -primOpTag (VecUnpackOp IntVec 32 W16) = 614 -primOpTag (VecUnpackOp IntVec 16 W32) = 615 -primOpTag (VecUnpackOp IntVec 8 W64) = 616 -primOpTag (VecUnpackOp WordVec 16 W8) = 617 -primOpTag (VecUnpackOp WordVec 8 W16) = 618 -primOpTag (VecUnpackOp WordVec 4 W32) = 619 -primOpTag (VecUnpackOp WordVec 2 W64) = 620 -primOpTag (VecUnpackOp WordVec 32 W8) = 621 -primOpTag (VecUnpackOp WordVec 16 W16) = 622 -primOpTag (VecUnpackOp WordVec 8 W32) = 623 -primOpTag (VecUnpackOp WordVec 4 W64) = 624 -primOpTag (VecUnpackOp WordVec 64 W8) = 625 -primOpTag (VecUnpackOp WordVec 32 W16) = 626 -primOpTag (VecUnpackOp WordVec 16 W32) = 627 -primOpTag (VecUnpackOp WordVec 8 W64) = 628 -primOpTag (VecUnpackOp FloatVec 4 W32) = 629 -primOpTag (VecUnpackOp FloatVec 2 W64) = 630 -primOpTag (VecUnpackOp FloatVec 8 W32) = 631 -primOpTag (VecUnpackOp FloatVec 4 W64) = 632 -primOpTag (VecUnpackOp FloatVec 16 W32) = 633 -primOpTag (VecUnpackOp FloatVec 8 W64) = 634 -primOpTag (VecInsertOp IntVec 16 W8) = 635 -primOpTag (VecInsertOp IntVec 8 W16) = 636 -primOpTag (VecInsertOp IntVec 4 W32) = 637 -primOpTag (VecInsertOp IntVec 2 W64) = 638 -primOpTag (VecInsertOp IntVec 32 W8) = 639 -primOpTag (VecInsertOp IntVec 16 W16) = 640 -primOpTag (VecInsertOp IntVec 8 W32) = 641 -primOpTag (VecInsertOp IntVec 4 W64) = 642 -primOpTag (VecInsertOp IntVec 64 W8) = 643 -primOpTag (VecInsertOp IntVec 32 W16) = 644 -primOpTag (VecInsertOp IntVec 16 W32) = 645 -primOpTag (VecInsertOp IntVec 8 W64) = 646 -primOpTag (VecInsertOp WordVec 16 W8) = 647 -primOpTag (VecInsertOp WordVec 8 W16) = 648 -primOpTag (VecInsertOp WordVec 4 W32) = 649 -primOpTag (VecInsertOp WordVec 2 W64) = 650 -primOpTag (VecInsertOp WordVec 32 W8) = 651 -primOpTag (VecInsertOp WordVec 16 W16) = 652 -primOpTag (VecInsertOp WordVec 8 W32) = 653 -primOpTag (VecInsertOp WordVec 4 W64) = 654 -primOpTag (VecInsertOp WordVec 64 W8) = 655 -primOpTag (VecInsertOp WordVec 32 W16) = 656 -primOpTag (VecInsertOp WordVec 16 W32) = 657 -primOpTag (VecInsertOp WordVec 8 W64) = 658 -primOpTag (VecInsertOp FloatVec 4 W32) = 659 -primOpTag (VecInsertOp FloatVec 2 W64) = 660 -primOpTag (VecInsertOp FloatVec 8 W32) = 661 -primOpTag (VecInsertOp FloatVec 4 W64) = 662 -primOpTag (VecInsertOp FloatVec 16 W32) = 663 -primOpTag (VecInsertOp FloatVec 8 W64) = 664 -primOpTag (VecAddOp IntVec 16 W8) = 665 -primOpTag (VecAddOp IntVec 8 W16) = 666 -primOpTag (VecAddOp IntVec 4 W32) = 667 -primOpTag (VecAddOp IntVec 2 W64) = 668 -primOpTag (VecAddOp IntVec 32 W8) = 669 -primOpTag (VecAddOp IntVec 16 W16) = 670 -primOpTag (VecAddOp IntVec 8 W32) = 671 -primOpTag (VecAddOp IntVec 4 W64) = 672 -primOpTag (VecAddOp IntVec 64 W8) = 673 -primOpTag (VecAddOp IntVec 32 W16) = 674 -primOpTag (VecAddOp IntVec 16 W32) = 675 -primOpTag (VecAddOp IntVec 8 W64) = 676 -primOpTag (VecAddOp WordVec 16 W8) = 677 -primOpTag (VecAddOp WordVec 8 W16) = 678 -primOpTag (VecAddOp WordVec 4 W32) = 679 -primOpTag (VecAddOp WordVec 2 W64) = 680 -primOpTag (VecAddOp WordVec 32 W8) = 681 -primOpTag (VecAddOp WordVec 16 W16) = 682 -primOpTag (VecAddOp WordVec 8 W32) = 683 -primOpTag (VecAddOp WordVec 4 W64) = 684 -primOpTag (VecAddOp WordVec 64 W8) = 685 -primOpTag (VecAddOp WordVec 32 W16) = 686 -primOpTag (VecAddOp WordVec 16 W32) = 687 -primOpTag (VecAddOp WordVec 8 W64) = 688 -primOpTag (VecAddOp FloatVec 4 W32) = 689 -primOpTag (VecAddOp FloatVec 2 W64) = 690 -primOpTag (VecAddOp FloatVec 8 W32) = 691 -primOpTag (VecAddOp FloatVec 4 W64) = 692 -primOpTag (VecAddOp FloatVec 16 W32) = 693 -primOpTag (VecAddOp FloatVec 8 W64) = 694 -primOpTag (VecSubOp IntVec 16 W8) = 695 -primOpTag (VecSubOp IntVec 8 W16) = 696 -primOpTag (VecSubOp IntVec 4 W32) = 697 -primOpTag (VecSubOp IntVec 2 W64) = 698 -primOpTag (VecSubOp IntVec 32 W8) = 699 -primOpTag (VecSubOp IntVec 16 W16) = 700 -primOpTag (VecSubOp IntVec 8 W32) = 701 -primOpTag (VecSubOp IntVec 4 W64) = 702 -primOpTag (VecSubOp IntVec 64 W8) = 703 -primOpTag (VecSubOp IntVec 32 W16) = 704 -primOpTag (VecSubOp IntVec 16 W32) = 705 -primOpTag (VecSubOp IntVec 8 W64) = 706 -primOpTag (VecSubOp WordVec 16 W8) = 707 -primOpTag (VecSubOp WordVec 8 W16) = 708 -primOpTag (VecSubOp WordVec 4 W32) = 709 -primOpTag (VecSubOp WordVec 2 W64) = 710 -primOpTag (VecSubOp WordVec 32 W8) = 711 -primOpTag (VecSubOp WordVec 16 W16) = 712 -primOpTag (VecSubOp WordVec 8 W32) = 713 -primOpTag (VecSubOp WordVec 4 W64) = 714 -primOpTag (VecSubOp WordVec 64 W8) = 715 -primOpTag (VecSubOp WordVec 32 W16) = 716 -primOpTag (VecSubOp WordVec 16 W32) = 717 -primOpTag (VecSubOp WordVec 8 W64) = 718 -primOpTag (VecSubOp FloatVec 4 W32) = 719 -primOpTag (VecSubOp FloatVec 2 W64) = 720 -primOpTag (VecSubOp FloatVec 8 W32) = 721 -primOpTag (VecSubOp FloatVec 4 W64) = 722 -primOpTag (VecSubOp FloatVec 16 W32) = 723 -primOpTag (VecSubOp FloatVec 8 W64) = 724 -primOpTag (VecMulOp IntVec 16 W8) = 725 -primOpTag (VecMulOp IntVec 8 W16) = 726 -primOpTag (VecMulOp IntVec 4 W32) = 727 -primOpTag (VecMulOp IntVec 2 W64) = 728 -primOpTag (VecMulOp IntVec 32 W8) = 729 -primOpTag (VecMulOp IntVec 16 W16) = 730 -primOpTag (VecMulOp IntVec 8 W32) = 731 -primOpTag (VecMulOp IntVec 4 W64) = 732 -primOpTag (VecMulOp IntVec 64 W8) = 733 -primOpTag (VecMulOp IntVec 32 W16) = 734 -primOpTag (VecMulOp IntVec 16 W32) = 735 -primOpTag (VecMulOp IntVec 8 W64) = 736 -primOpTag (VecMulOp WordVec 16 W8) = 737 -primOpTag (VecMulOp WordVec 8 W16) = 738 -primOpTag (VecMulOp WordVec 4 W32) = 739 -primOpTag (VecMulOp WordVec 2 W64) = 740 -primOpTag (VecMulOp WordVec 32 W8) = 741 -primOpTag (VecMulOp WordVec 16 W16) = 742 -primOpTag (VecMulOp WordVec 8 W32) = 743 -primOpTag (VecMulOp WordVec 4 W64) = 744 -primOpTag (VecMulOp WordVec 64 W8) = 745 -primOpTag (VecMulOp WordVec 32 W16) = 746 -primOpTag (VecMulOp WordVec 16 W32) = 747 -primOpTag (VecMulOp WordVec 8 W64) = 748 -primOpTag (VecMulOp FloatVec 4 W32) = 749 -primOpTag (VecMulOp FloatVec 2 W64) = 750 -primOpTag (VecMulOp FloatVec 8 W32) = 751 -primOpTag (VecMulOp FloatVec 4 W64) = 752 -primOpTag (VecMulOp FloatVec 16 W32) = 753 -primOpTag (VecMulOp FloatVec 8 W64) = 754 -primOpTag (VecDivOp FloatVec 4 W32) = 755 -primOpTag (VecDivOp FloatVec 2 W64) = 756 -primOpTag (VecDivOp FloatVec 8 W32) = 757 -primOpTag (VecDivOp FloatVec 4 W64) = 758 -primOpTag (VecDivOp FloatVec 16 W32) = 759 -primOpTag (VecDivOp FloatVec 8 W64) = 760 -primOpTag (VecQuotOp IntVec 16 W8) = 761 -primOpTag (VecQuotOp IntVec 8 W16) = 762 -primOpTag (VecQuotOp IntVec 4 W32) = 763 -primOpTag (VecQuotOp IntVec 2 W64) = 764 -primOpTag (VecQuotOp IntVec 32 W8) = 765 -primOpTag (VecQuotOp IntVec 16 W16) = 766 -primOpTag (VecQuotOp IntVec 8 W32) = 767 -primOpTag (VecQuotOp IntVec 4 W64) = 768 -primOpTag (VecQuotOp IntVec 64 W8) = 769 -primOpTag (VecQuotOp IntVec 32 W16) = 770 -primOpTag (VecQuotOp IntVec 16 W32) = 771 -primOpTag (VecQuotOp IntVec 8 W64) = 772 -primOpTag (VecQuotOp WordVec 16 W8) = 773 -primOpTag (VecQuotOp WordVec 8 W16) = 774 -primOpTag (VecQuotOp WordVec 4 W32) = 775 -primOpTag (VecQuotOp WordVec 2 W64) = 776 -primOpTag (VecQuotOp WordVec 32 W8) = 777 -primOpTag (VecQuotOp WordVec 16 W16) = 778 -primOpTag (VecQuotOp WordVec 8 W32) = 779 -primOpTag (VecQuotOp WordVec 4 W64) = 780 -primOpTag (VecQuotOp WordVec 64 W8) = 781 -primOpTag (VecQuotOp WordVec 32 W16) = 782 -primOpTag (VecQuotOp WordVec 16 W32) = 783 -primOpTag (VecQuotOp WordVec 8 W64) = 784 -primOpTag (VecRemOp IntVec 16 W8) = 785 -primOpTag (VecRemOp IntVec 8 W16) = 786 -primOpTag (VecRemOp IntVec 4 W32) = 787 -primOpTag (VecRemOp IntVec 2 W64) = 788 -primOpTag (VecRemOp IntVec 32 W8) = 789 -primOpTag (VecRemOp IntVec 16 W16) = 790 -primOpTag (VecRemOp IntVec 8 W32) = 791 -primOpTag (VecRemOp IntVec 4 W64) = 792 -primOpTag (VecRemOp IntVec 64 W8) = 793 -primOpTag (VecRemOp IntVec 32 W16) = 794 -primOpTag (VecRemOp IntVec 16 W32) = 795 -primOpTag (VecRemOp IntVec 8 W64) = 796 -primOpTag (VecRemOp WordVec 16 W8) = 797 -primOpTag (VecRemOp WordVec 8 W16) = 798 -primOpTag (VecRemOp WordVec 4 W32) = 799 -primOpTag (VecRemOp WordVec 2 W64) = 800 -primOpTag (VecRemOp WordVec 32 W8) = 801 -primOpTag (VecRemOp WordVec 16 W16) = 802 -primOpTag (VecRemOp WordVec 8 W32) = 803 -primOpTag (VecRemOp WordVec 4 W64) = 804 -primOpTag (VecRemOp WordVec 64 W8) = 805 -primOpTag (VecRemOp WordVec 32 W16) = 806 -primOpTag (VecRemOp WordVec 16 W32) = 807 -primOpTag (VecRemOp WordVec 8 W64) = 808 -primOpTag (VecNegOp IntVec 16 W8) = 809 -primOpTag (VecNegOp IntVec 8 W16) = 810 -primOpTag (VecNegOp IntVec 4 W32) = 811 -primOpTag (VecNegOp IntVec 2 W64) = 812 -primOpTag (VecNegOp IntVec 32 W8) = 813 -primOpTag (VecNegOp IntVec 16 W16) = 814 -primOpTag (VecNegOp IntVec 8 W32) = 815 -primOpTag (VecNegOp IntVec 4 W64) = 816 -primOpTag (VecNegOp IntVec 64 W8) = 817 -primOpTag (VecNegOp IntVec 32 W16) = 818 -primOpTag (VecNegOp IntVec 16 W32) = 819 -primOpTag (VecNegOp IntVec 8 W64) = 820 -primOpTag (VecNegOp FloatVec 4 W32) = 821 -primOpTag (VecNegOp FloatVec 2 W64) = 822 -primOpTag (VecNegOp FloatVec 8 W32) = 823 -primOpTag (VecNegOp FloatVec 4 W64) = 824 -primOpTag (VecNegOp FloatVec 16 W32) = 825 -primOpTag (VecNegOp FloatVec 8 W64) = 826 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 827 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 828 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 829 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 830 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 831 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 832 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 833 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 834 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 835 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 836 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 837 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 838 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 839 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 840 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 841 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 842 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 843 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 844 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 845 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 846 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 847 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 848 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 849 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 850 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 851 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 852 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 853 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 854 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 855 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 856 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 857 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 858 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 859 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 860 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 861 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 862 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 863 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 864 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 865 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 866 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 867 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 868 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 869 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 870 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 871 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 872 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 873 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 874 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 875 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 876 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 877 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 878 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 879 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 880 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 881 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 882 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 883 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 884 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 885 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 886 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 887 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 888 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 889 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 890 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 891 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 892 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 893 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 894 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 895 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 896 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 897 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 898 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 899 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 900 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 901 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 902 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 903 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 904 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 905 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 906 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 907 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 908 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 909 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 910 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 911 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 912 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 913 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 914 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 915 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 916 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 917 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 918 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 919 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 920 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 921 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 922 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 923 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 924 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 925 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 926 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 927 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 928 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 929 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 930 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 931 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 932 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 933 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 934 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 935 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 936 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 937 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 938 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 939 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 940 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 941 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 942 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 943 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 944 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 945 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 946 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 947 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 948 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 949 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 950 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 951 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 952 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 953 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 954 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 955 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 956 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 957 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 958 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 959 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 960 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 961 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 962 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 963 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 964 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 965 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 966 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 967 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 968 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 969 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 970 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 971 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 972 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 973 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 974 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 975 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 976 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 977 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 978 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 979 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 980 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 981 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 982 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 983 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 984 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 985 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 986 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 987 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 988 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 989 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 990 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 991 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 992 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 993 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 994 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 995 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 996 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 997 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 998 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 999 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1000 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1001 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1002 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1003 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1004 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1005 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1006 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1007 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1008 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1009 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1010 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1011 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1012 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1013 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1014 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1015 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1016 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1017 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1018 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1019 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1020 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1021 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1022 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1023 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1024 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1025 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1026 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1027 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1028 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1029 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1030 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1031 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1032 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1033 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1034 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1035 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1036 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1037 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1038 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1039 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1040 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1041 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1042 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1043 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1044 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1045 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1046 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1047 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1048 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1049 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1050 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1051 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1052 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1053 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1054 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1055 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1056 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1057 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1058 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1059 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1060 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1061 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1062 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1063 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1064 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1065 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1066 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1067 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1068 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1069 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1070 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1071 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1072 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1073 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1074 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1075 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1076 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1077 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1078 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1079 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1080 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1081 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1082 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1083 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1084 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1085 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1086 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1087 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1088 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1089 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1090 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1091 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1092 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1093 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1094 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1095 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1096 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1097 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1098 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1099 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1100 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1101 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1102 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1103 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1104 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1105 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1106 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1107 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1108 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1109 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1110 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1111 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1112 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1113 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1114 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1115 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1116 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1117 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1118 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1119 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1120 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1121 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1122 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1123 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1124 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1125 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1126 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1127 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1128 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1129 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1130 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1131 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1132 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1133 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1134 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1135 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1136 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1137 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1138 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1139 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1140 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1141 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1142 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1143 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1144 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1145 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1146 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1147 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1148 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1149 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1150 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1151 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1152 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1153 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1154 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1155 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1156 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1157 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1158 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1159 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1160 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1161 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1162 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1163 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1164 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1165 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1166 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1167 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1168 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1169 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1170 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1171 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1172 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1173 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1174 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1175 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1176 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1177 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1178 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1179 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1180 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1181 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1182 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1183 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1184 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1185 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1186 -primOpTag PrefetchByteArrayOp3 = 1187 -primOpTag PrefetchMutableByteArrayOp3 = 1188 -primOpTag PrefetchAddrOp3 = 1189 -primOpTag PrefetchValueOp3 = 1190 -primOpTag PrefetchByteArrayOp2 = 1191 -primOpTag PrefetchMutableByteArrayOp2 = 1192 -primOpTag PrefetchAddrOp2 = 1193 -primOpTag PrefetchValueOp2 = 1194 -primOpTag PrefetchByteArrayOp1 = 1195 -primOpTag PrefetchMutableByteArrayOp1 = 1196 -primOpTag PrefetchAddrOp1 = 1197 -primOpTag PrefetchValueOp1 = 1198 -primOpTag PrefetchByteArrayOp0 = 1199 -primOpTag PrefetchMutableByteArrayOp0 = 1200 -primOpTag PrefetchAddrOp0 = 1201 -primOpTag PrefetchValueOp0 = 1202 +maxPrimOpTag = 1201 +primOpTag :: PrimOp -> Int +primOpTag CharGtOp = 1 +primOpTag CharGeOp = 2 +primOpTag CharEqOp = 3 +primOpTag CharNeOp = 4 +primOpTag CharLtOp = 5 +primOpTag CharLeOp = 6 +primOpTag OrdOp = 7 +primOpTag IntAddOp = 8 +primOpTag IntSubOp = 9 +primOpTag IntMulOp = 10 +primOpTag IntMulMayOfloOp = 11 +primOpTag IntQuotOp = 12 +primOpTag IntRemOp = 13 +primOpTag IntQuotRemOp = 14 +primOpTag AndIOp = 15 +primOpTag OrIOp = 16 +primOpTag XorIOp = 17 +primOpTag NotIOp = 18 +primOpTag IntNegOp = 19 +primOpTag IntAddCOp = 20 +primOpTag IntSubCOp = 21 +primOpTag IntGtOp = 22 +primOpTag IntGeOp = 23 +primOpTag IntEqOp = 24 +primOpTag IntNeOp = 25 +primOpTag IntLtOp = 26 +primOpTag IntLeOp = 27 +primOpTag ChrOp = 28 +primOpTag Int2WordOp = 29 +primOpTag Int2FloatOp = 30 +primOpTag Int2DoubleOp = 31 +primOpTag Word2FloatOp = 32 +primOpTag Word2DoubleOp = 33 +primOpTag ISllOp = 34 +primOpTag ISraOp = 35 +primOpTag ISrlOp = 36 +primOpTag Int8Extend = 37 +primOpTag Int8Narrow = 38 +primOpTag Int8NegOp = 39 +primOpTag Int8AddOp = 40 +primOpTag Int8SubOp = 41 +primOpTag Int8MulOp = 42 +primOpTag Int8QuotOp = 43 +primOpTag Int8RemOp = 44 +primOpTag Int8QuotRemOp = 45 +primOpTag Int8EqOp = 46 +primOpTag Int8GeOp = 47 +primOpTag Int8GtOp = 48 +primOpTag Int8LeOp = 49 +primOpTag Int8LtOp = 50 +primOpTag Int8NeOp = 51 +primOpTag Word8Extend = 52 +primOpTag Word8Narrow = 53 +primOpTag Word8NotOp = 54 +primOpTag Word8AddOp = 55 +primOpTag Word8SubOp = 56 +primOpTag Word8MulOp = 57 +primOpTag Word8QuotOp = 58 +primOpTag Word8RemOp = 59 +primOpTag Word8QuotRemOp = 60 +primOpTag Word8EqOp = 61 +primOpTag Word8GeOp = 62 +primOpTag Word8GtOp = 63 +primOpTag Word8LeOp = 64 +primOpTag Word8LtOp = 65 +primOpTag Word8NeOp = 66 +primOpTag Int16Extend = 67 +primOpTag Int16Narrow = 68 +primOpTag Int16NegOp = 69 +primOpTag Int16AddOp = 70 +primOpTag Int16SubOp = 71 +primOpTag Int16MulOp = 72 +primOpTag Int16QuotOp = 73 +primOpTag Int16RemOp = 74 +primOpTag Int16QuotRemOp = 75 +primOpTag Int16EqOp = 76 +primOpTag Int16GeOp = 77 +primOpTag Int16GtOp = 78 +primOpTag Int16LeOp = 79 +primOpTag Int16LtOp = 80 +primOpTag Int16NeOp = 81 +primOpTag Word16Extend = 82 +primOpTag Word16Narrow = 83 +primOpTag Word16NotOp = 84 +primOpTag Word16AddOp = 85 +primOpTag Word16SubOp = 86 +primOpTag Word16MulOp = 87 +primOpTag Word16QuotOp = 88 +primOpTag Word16RemOp = 89 +primOpTag Word16QuotRemOp = 90 +primOpTag Word16EqOp = 91 +primOpTag Word16GeOp = 92 +primOpTag Word16GtOp = 93 +primOpTag Word16LeOp = 94 +primOpTag Word16LtOp = 95 +primOpTag Word16NeOp = 96 +primOpTag WordAddOp = 97 +primOpTag WordAddCOp = 98 +primOpTag WordSubCOp = 99 +primOpTag WordAdd2Op = 100 +primOpTag WordSubOp = 101 +primOpTag WordMulOp = 102 +primOpTag WordMul2Op = 103 +primOpTag WordQuotOp = 104 +primOpTag WordRemOp = 105 +primOpTag WordQuotRemOp = 106 +primOpTag WordQuotRem2Op = 107 +primOpTag AndOp = 108 +primOpTag OrOp = 109 +primOpTag XorOp = 110 +primOpTag NotOp = 111 +primOpTag SllOp = 112 +primOpTag SrlOp = 113 +primOpTag Word2IntOp = 114 +primOpTag WordGtOp = 115 +primOpTag WordGeOp = 116 +primOpTag WordEqOp = 117 +primOpTag WordNeOp = 118 +primOpTag WordLtOp = 119 +primOpTag WordLeOp = 120 +primOpTag PopCnt8Op = 121 +primOpTag PopCnt16Op = 122 +primOpTag PopCnt32Op = 123 +primOpTag PopCnt64Op = 124 +primOpTag PopCntOp = 125 +primOpTag Pdep8Op = 126 +primOpTag Pdep16Op = 127 +primOpTag Pdep32Op = 128 +primOpTag Pdep64Op = 129 +primOpTag PdepOp = 130 +primOpTag Pext8Op = 131 +primOpTag Pext16Op = 132 +primOpTag Pext32Op = 133 +primOpTag Pext64Op = 134 +primOpTag PextOp = 135 +primOpTag Clz8Op = 136 +primOpTag Clz16Op = 137 +primOpTag Clz32Op = 138 +primOpTag Clz64Op = 139 +primOpTag ClzOp = 140 +primOpTag Ctz8Op = 141 +primOpTag Ctz16Op = 142 +primOpTag Ctz32Op = 143 +primOpTag Ctz64Op = 144 +primOpTag CtzOp = 145 +primOpTag BSwap16Op = 146 +primOpTag BSwap32Op = 147 +primOpTag BSwap64Op = 148 +primOpTag BSwapOp = 149 +primOpTag BRev8Op = 150 +primOpTag BRev16Op = 151 +primOpTag BRev32Op = 152 +primOpTag BRev64Op = 153 +primOpTag BRevOp = 154 +primOpTag Narrow8IntOp = 155 +primOpTag Narrow16IntOp = 156 +primOpTag Narrow32IntOp = 157 +primOpTag Narrow8WordOp = 158 +primOpTag Narrow16WordOp = 159 +primOpTag Narrow32WordOp = 160 +primOpTag DoubleGtOp = 161 +primOpTag DoubleGeOp = 162 +primOpTag DoubleEqOp = 163 +primOpTag DoubleNeOp = 164 +primOpTag DoubleLtOp = 165 +primOpTag DoubleLeOp = 166 +primOpTag DoubleAddOp = 167 +primOpTag DoubleSubOp = 168 +primOpTag DoubleMulOp = 169 +primOpTag DoubleDivOp = 170 +primOpTag DoubleNegOp = 171 +primOpTag DoubleFabsOp = 172 +primOpTag Double2IntOp = 173 +primOpTag Double2FloatOp = 174 +primOpTag DoubleExpOp = 175 +primOpTag DoubleExpM1Op = 176 +primOpTag DoubleLogOp = 177 +primOpTag DoubleLog1POp = 178 +primOpTag DoubleSqrtOp = 179 +primOpTag DoubleSinOp = 180 +primOpTag DoubleCosOp = 181 +primOpTag DoubleTanOp = 182 +primOpTag DoubleAsinOp = 183 +primOpTag DoubleAcosOp = 184 +primOpTag DoubleAtanOp = 185 +primOpTag DoubleSinhOp = 186 +primOpTag DoubleCoshOp = 187 +primOpTag DoubleTanhOp = 188 +primOpTag DoubleAsinhOp = 189 +primOpTag DoubleAcoshOp = 190 +primOpTag DoubleAtanhOp = 191 +primOpTag DoublePowerOp = 192 +primOpTag DoubleDecode_2IntOp = 193 +primOpTag DoubleDecode_Int64Op = 194 +primOpTag FloatGtOp = 195 +primOpTag FloatGeOp = 196 +primOpTag FloatEqOp = 197 +primOpTag FloatNeOp = 198 +primOpTag FloatLtOp = 199 +primOpTag FloatLeOp = 200 +primOpTag FloatAddOp = 201 +primOpTag FloatSubOp = 202 +primOpTag FloatMulOp = 203 +primOpTag FloatDivOp = 204 +primOpTag FloatNegOp = 205 +primOpTag FloatFabsOp = 206 +primOpTag Float2IntOp = 207 +primOpTag FloatExpOp = 208 +primOpTag FloatExpM1Op = 209 +primOpTag FloatLogOp = 210 +primOpTag FloatLog1POp = 211 +primOpTag FloatSqrtOp = 212 +primOpTag FloatSinOp = 213 +primOpTag FloatCosOp = 214 +primOpTag FloatTanOp = 215 +primOpTag FloatAsinOp = 216 +primOpTag FloatAcosOp = 217 +primOpTag FloatAtanOp = 218 +primOpTag FloatSinhOp = 219 +primOpTag FloatCoshOp = 220 +primOpTag FloatTanhOp = 221 +primOpTag FloatAsinhOp = 222 +primOpTag FloatAcoshOp = 223 +primOpTag FloatAtanhOp = 224 +primOpTag FloatPowerOp = 225 +primOpTag Float2DoubleOp = 226 +primOpTag FloatDecode_IntOp = 227 +primOpTag NewArrayOp = 228 +primOpTag SameMutableArrayOp = 229 +primOpTag ReadArrayOp = 230 +primOpTag WriteArrayOp = 231 +primOpTag SizeofArrayOp = 232 +primOpTag SizeofMutableArrayOp = 233 +primOpTag IndexArrayOp = 234 +primOpTag UnsafeFreezeArrayOp = 235 +primOpTag UnsafeThawArrayOp = 236 +primOpTag CopyArrayOp = 237 +primOpTag CopyMutableArrayOp = 238 +primOpTag CloneArrayOp = 239 +primOpTag CloneMutableArrayOp = 240 +primOpTag FreezeArrayOp = 241 +primOpTag ThawArrayOp = 242 +primOpTag CasArrayOp = 243 +primOpTag NewSmallArrayOp = 244 +primOpTag SameSmallMutableArrayOp = 245 +primOpTag ReadSmallArrayOp = 246 +primOpTag WriteSmallArrayOp = 247 +primOpTag SizeofSmallArrayOp = 248 +primOpTag SizeofSmallMutableArrayOp = 249 +primOpTag IndexSmallArrayOp = 250 +primOpTag UnsafeFreezeSmallArrayOp = 251 +primOpTag UnsafeThawSmallArrayOp = 252 +primOpTag CopySmallArrayOp = 253 +primOpTag CopySmallMutableArrayOp = 254 +primOpTag CloneSmallArrayOp = 255 +primOpTag CloneSmallMutableArrayOp = 256 +primOpTag FreezeSmallArrayOp = 257 +primOpTag ThawSmallArrayOp = 258 +primOpTag CasSmallArrayOp = 259 +primOpTag NewByteArrayOp_Char = 260 +primOpTag NewPinnedByteArrayOp_Char = 261 +primOpTag NewAlignedPinnedByteArrayOp_Char = 262 +primOpTag MutableByteArrayIsPinnedOp = 263 +primOpTag ByteArrayIsPinnedOp = 264 +primOpTag ByteArrayContents_Char = 265 +primOpTag SameMutableByteArrayOp = 266 +primOpTag ShrinkMutableByteArrayOp_Char = 267 +primOpTag ResizeMutableByteArrayOp_Char = 268 +primOpTag UnsafeFreezeByteArrayOp = 269 +primOpTag SizeofByteArrayOp = 270 +primOpTag SizeofMutableByteArrayOp = 271 +primOpTag GetSizeofMutableByteArrayOp = 272 +primOpTag IndexByteArrayOp_Char = 273 +primOpTag IndexByteArrayOp_WideChar = 274 +primOpTag IndexByteArrayOp_Int = 275 +primOpTag IndexByteArrayOp_Word = 276 +primOpTag IndexByteArrayOp_Addr = 277 +primOpTag IndexByteArrayOp_Float = 278 +primOpTag IndexByteArrayOp_Double = 279 +primOpTag IndexByteArrayOp_StablePtr = 280 +primOpTag IndexByteArrayOp_Int8 = 281 +primOpTag IndexByteArrayOp_Int16 = 282 +primOpTag IndexByteArrayOp_Int32 = 283 +primOpTag IndexByteArrayOp_Int64 = 284 +primOpTag IndexByteArrayOp_Word8 = 285 +primOpTag IndexByteArrayOp_Word16 = 286 +primOpTag IndexByteArrayOp_Word32 = 287 +primOpTag IndexByteArrayOp_Word64 = 288 +primOpTag IndexByteArrayOp_Word8AsChar = 289 +primOpTag IndexByteArrayOp_Word8AsWideChar = 290 +primOpTag IndexByteArrayOp_Word8AsAddr = 291 +primOpTag IndexByteArrayOp_Word8AsFloat = 292 +primOpTag IndexByteArrayOp_Word8AsDouble = 293 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 294 +primOpTag IndexByteArrayOp_Word8AsInt16 = 295 +primOpTag IndexByteArrayOp_Word8AsInt32 = 296 +primOpTag IndexByteArrayOp_Word8AsInt64 = 297 +primOpTag IndexByteArrayOp_Word8AsInt = 298 +primOpTag IndexByteArrayOp_Word8AsWord16 = 299 +primOpTag IndexByteArrayOp_Word8AsWord32 = 300 +primOpTag IndexByteArrayOp_Word8AsWord64 = 301 +primOpTag IndexByteArrayOp_Word8AsWord = 302 +primOpTag ReadByteArrayOp_Char = 303 +primOpTag ReadByteArrayOp_WideChar = 304 +primOpTag ReadByteArrayOp_Int = 305 +primOpTag ReadByteArrayOp_Word = 306 +primOpTag ReadByteArrayOp_Addr = 307 +primOpTag ReadByteArrayOp_Float = 308 +primOpTag ReadByteArrayOp_Double = 309 +primOpTag ReadByteArrayOp_StablePtr = 310 +primOpTag ReadByteArrayOp_Int8 = 311 +primOpTag ReadByteArrayOp_Int16 = 312 +primOpTag ReadByteArrayOp_Int32 = 313 +primOpTag ReadByteArrayOp_Int64 = 314 +primOpTag ReadByteArrayOp_Word8 = 315 +primOpTag ReadByteArrayOp_Word16 = 316 +primOpTag ReadByteArrayOp_Word32 = 317 +primOpTag ReadByteArrayOp_Word64 = 318 +primOpTag ReadByteArrayOp_Word8AsChar = 319 +primOpTag ReadByteArrayOp_Word8AsWideChar = 320 +primOpTag ReadByteArrayOp_Word8AsAddr = 321 +primOpTag ReadByteArrayOp_Word8AsFloat = 322 +primOpTag ReadByteArrayOp_Word8AsDouble = 323 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 324 +primOpTag ReadByteArrayOp_Word8AsInt16 = 325 +primOpTag ReadByteArrayOp_Word8AsInt32 = 326 +primOpTag ReadByteArrayOp_Word8AsInt64 = 327 +primOpTag ReadByteArrayOp_Word8AsInt = 328 +primOpTag ReadByteArrayOp_Word8AsWord16 = 329 +primOpTag ReadByteArrayOp_Word8AsWord32 = 330 +primOpTag ReadByteArrayOp_Word8AsWord64 = 331 +primOpTag ReadByteArrayOp_Word8AsWord = 332 +primOpTag WriteByteArrayOp_Char = 333 +primOpTag WriteByteArrayOp_WideChar = 334 +primOpTag WriteByteArrayOp_Int = 335 +primOpTag WriteByteArrayOp_Word = 336 +primOpTag WriteByteArrayOp_Addr = 337 +primOpTag WriteByteArrayOp_Float = 338 +primOpTag WriteByteArrayOp_Double = 339 +primOpTag WriteByteArrayOp_StablePtr = 340 +primOpTag WriteByteArrayOp_Int8 = 341 +primOpTag WriteByteArrayOp_Int16 = 342 +primOpTag WriteByteArrayOp_Int32 = 343 +primOpTag WriteByteArrayOp_Int64 = 344 +primOpTag WriteByteArrayOp_Word8 = 345 +primOpTag WriteByteArrayOp_Word16 = 346 +primOpTag WriteByteArrayOp_Word32 = 347 +primOpTag WriteByteArrayOp_Word64 = 348 +primOpTag WriteByteArrayOp_Word8AsChar = 349 +primOpTag WriteByteArrayOp_Word8AsWideChar = 350 +primOpTag WriteByteArrayOp_Word8AsAddr = 351 +primOpTag WriteByteArrayOp_Word8AsFloat = 352 +primOpTag WriteByteArrayOp_Word8AsDouble = 353 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 354 +primOpTag WriteByteArrayOp_Word8AsInt16 = 355 +primOpTag WriteByteArrayOp_Word8AsInt32 = 356 +primOpTag WriteByteArrayOp_Word8AsInt64 = 357 +primOpTag WriteByteArrayOp_Word8AsInt = 358 +primOpTag WriteByteArrayOp_Word8AsWord16 = 359 +primOpTag WriteByteArrayOp_Word8AsWord32 = 360 +primOpTag WriteByteArrayOp_Word8AsWord64 = 361 +primOpTag WriteByteArrayOp_Word8AsWord = 362 +primOpTag CompareByteArraysOp = 363 +primOpTag CopyByteArrayOp = 364 +primOpTag CopyMutableByteArrayOp = 365 +primOpTag CopyByteArrayToAddrOp = 366 +primOpTag CopyMutableByteArrayToAddrOp = 367 +primOpTag CopyAddrToByteArrayOp = 368 +primOpTag SetByteArrayOp = 369 +primOpTag AtomicReadByteArrayOp_Int = 370 +primOpTag AtomicWriteByteArrayOp_Int = 371 +primOpTag CasByteArrayOp_Int = 372 +primOpTag FetchAddByteArrayOp_Int = 373 +primOpTag FetchSubByteArrayOp_Int = 374 +primOpTag FetchAndByteArrayOp_Int = 375 +primOpTag FetchNandByteArrayOp_Int = 376 +primOpTag FetchOrByteArrayOp_Int = 377 +primOpTag FetchXorByteArrayOp_Int = 378 +primOpTag NewArrayArrayOp = 379 +primOpTag SameMutableArrayArrayOp = 380 +primOpTag UnsafeFreezeArrayArrayOp = 381 +primOpTag SizeofArrayArrayOp = 382 +primOpTag SizeofMutableArrayArrayOp = 383 +primOpTag IndexArrayArrayOp_ByteArray = 384 +primOpTag IndexArrayArrayOp_ArrayArray = 385 +primOpTag ReadArrayArrayOp_ByteArray = 386 +primOpTag ReadArrayArrayOp_MutableByteArray = 387 +primOpTag ReadArrayArrayOp_ArrayArray = 388 +primOpTag ReadArrayArrayOp_MutableArrayArray = 389 +primOpTag WriteArrayArrayOp_ByteArray = 390 +primOpTag WriteArrayArrayOp_MutableByteArray = 391 +primOpTag WriteArrayArrayOp_ArrayArray = 392 +primOpTag WriteArrayArrayOp_MutableArrayArray = 393 +primOpTag CopyArrayArrayOp = 394 +primOpTag CopyMutableArrayArrayOp = 395 +primOpTag AddrAddOp = 396 +primOpTag AddrSubOp = 397 +primOpTag AddrRemOp = 398 +primOpTag Addr2IntOp = 399 +primOpTag Int2AddrOp = 400 +primOpTag AddrGtOp = 401 +primOpTag AddrGeOp = 402 +primOpTag AddrEqOp = 403 +primOpTag AddrNeOp = 404 +primOpTag AddrLtOp = 405 +primOpTag AddrLeOp = 406 +primOpTag IndexOffAddrOp_Char = 407 +primOpTag IndexOffAddrOp_WideChar = 408 +primOpTag IndexOffAddrOp_Int = 409 +primOpTag IndexOffAddrOp_Word = 410 +primOpTag IndexOffAddrOp_Addr = 411 +primOpTag IndexOffAddrOp_Float = 412 +primOpTag IndexOffAddrOp_Double = 413 +primOpTag IndexOffAddrOp_StablePtr = 414 +primOpTag IndexOffAddrOp_Int8 = 415 +primOpTag IndexOffAddrOp_Int16 = 416 +primOpTag IndexOffAddrOp_Int32 = 417 +primOpTag IndexOffAddrOp_Int64 = 418 +primOpTag IndexOffAddrOp_Word8 = 419 +primOpTag IndexOffAddrOp_Word16 = 420 +primOpTag IndexOffAddrOp_Word32 = 421 +primOpTag IndexOffAddrOp_Word64 = 422 +primOpTag ReadOffAddrOp_Char = 423 +primOpTag ReadOffAddrOp_WideChar = 424 +primOpTag ReadOffAddrOp_Int = 425 +primOpTag ReadOffAddrOp_Word = 426 +primOpTag ReadOffAddrOp_Addr = 427 +primOpTag ReadOffAddrOp_Float = 428 +primOpTag ReadOffAddrOp_Double = 429 +primOpTag ReadOffAddrOp_StablePtr = 430 +primOpTag ReadOffAddrOp_Int8 = 431 +primOpTag ReadOffAddrOp_Int16 = 432 +primOpTag ReadOffAddrOp_Int32 = 433 +primOpTag ReadOffAddrOp_Int64 = 434 +primOpTag ReadOffAddrOp_Word8 = 435 +primOpTag ReadOffAddrOp_Word16 = 436 +primOpTag ReadOffAddrOp_Word32 = 437 +primOpTag ReadOffAddrOp_Word64 = 438 +primOpTag WriteOffAddrOp_Char = 439 +primOpTag WriteOffAddrOp_WideChar = 440 +primOpTag WriteOffAddrOp_Int = 441 +primOpTag WriteOffAddrOp_Word = 442 +primOpTag WriteOffAddrOp_Addr = 443 +primOpTag WriteOffAddrOp_Float = 444 +primOpTag WriteOffAddrOp_Double = 445 +primOpTag WriteOffAddrOp_StablePtr = 446 +primOpTag WriteOffAddrOp_Int8 = 447 +primOpTag WriteOffAddrOp_Int16 = 448 +primOpTag WriteOffAddrOp_Int32 = 449 +primOpTag WriteOffAddrOp_Int64 = 450 +primOpTag WriteOffAddrOp_Word8 = 451 +primOpTag WriteOffAddrOp_Word16 = 452 +primOpTag WriteOffAddrOp_Word32 = 453 +primOpTag WriteOffAddrOp_Word64 = 454 +primOpTag NewMutVarOp = 455 +primOpTag ReadMutVarOp = 456 +primOpTag WriteMutVarOp = 457 +primOpTag SameMutVarOp = 458 +primOpTag AtomicModifyMutVar2Op = 459 +primOpTag AtomicModifyMutVar_Op = 460 +primOpTag CasMutVarOp = 461 +primOpTag CatchOp = 462 +primOpTag RaiseOp = 463 +primOpTag RaiseIOOp = 464 +primOpTag MaskAsyncExceptionsOp = 465 +primOpTag MaskUninterruptibleOp = 466 +primOpTag UnmaskAsyncExceptionsOp = 467 +primOpTag MaskStatus = 468 +primOpTag AtomicallyOp = 469 +primOpTag RetryOp = 470 +primOpTag CatchRetryOp = 471 +primOpTag CatchSTMOp = 472 +primOpTag NewTVarOp = 473 +primOpTag ReadTVarOp = 474 +primOpTag ReadTVarIOOp = 475 +primOpTag WriteTVarOp = 476 +primOpTag SameTVarOp = 477 +primOpTag NewMVarOp = 478 +primOpTag TakeMVarOp = 479 +primOpTag TryTakeMVarOp = 480 +primOpTag PutMVarOp = 481 +primOpTag TryPutMVarOp = 482 +primOpTag ReadMVarOp = 483 +primOpTag TryReadMVarOp = 484 +primOpTag SameMVarOp = 485 +primOpTag IsEmptyMVarOp = 486 +primOpTag DelayOp = 487 +primOpTag WaitReadOp = 488 +primOpTag WaitWriteOp = 489 +primOpTag ForkOp = 490 +primOpTag ForkOnOp = 491 +primOpTag KillThreadOp = 492 +primOpTag YieldOp = 493 +primOpTag MyThreadIdOp = 494 +primOpTag LabelThreadOp = 495 +primOpTag IsCurrentThreadBoundOp = 496 +primOpTag NoDuplicateOp = 497 +primOpTag ThreadStatusOp = 498 +primOpTag MkWeakOp = 499 +primOpTag MkWeakNoFinalizerOp = 500 +primOpTag AddCFinalizerToWeakOp = 501 +primOpTag DeRefWeakOp = 502 +primOpTag FinalizeWeakOp = 503 +primOpTag TouchOp = 504 +primOpTag MakeStablePtrOp = 505 +primOpTag DeRefStablePtrOp = 506 +primOpTag EqStablePtrOp = 507 +primOpTag MakeStableNameOp = 508 +primOpTag EqStableNameOp = 509 +primOpTag StableNameToIntOp = 510 +primOpTag CompactNewOp = 511 +primOpTag CompactResizeOp = 512 +primOpTag CompactContainsOp = 513 +primOpTag CompactContainsAnyOp = 514 +primOpTag CompactGetFirstBlockOp = 515 +primOpTag CompactGetNextBlockOp = 516 +primOpTag CompactAllocateBlockOp = 517 +primOpTag CompactFixupPointersOp = 518 +primOpTag CompactAdd = 519 +primOpTag CompactAddWithSharing = 520 +primOpTag CompactSize = 521 +primOpTag ReallyUnsafePtrEqualityOp = 522 +primOpTag ParOp = 523 +primOpTag SparkOp = 524 +primOpTag SeqOp = 525 +primOpTag GetSparkOp = 526 +primOpTag NumSparks = 527 +primOpTag DataToTagOp = 528 +primOpTag TagToEnumOp = 529 +primOpTag AddrToAnyOp = 530 +primOpTag AnyToAddrOp = 531 +primOpTag MkApUpd0_Op = 532 +primOpTag NewBCOOp = 533 +primOpTag UnpackClosureOp = 534 +primOpTag ClosureSizeOp = 535 +primOpTag GetApStackValOp = 536 +primOpTag GetCCSOfOp = 537 +primOpTag GetCurrentCCSOp = 538 +primOpTag ClearCCSOp = 539 +primOpTag TraceEventOp = 540 +primOpTag TraceEventBinaryOp = 541 +primOpTag TraceMarkerOp = 542 +primOpTag SetThreadAllocationCounter = 543 +primOpTag (VecBroadcastOp IntVec 16 W8) = 544 +primOpTag (VecBroadcastOp IntVec 8 W16) = 545 +primOpTag (VecBroadcastOp IntVec 4 W32) = 546 +primOpTag (VecBroadcastOp IntVec 2 W64) = 547 +primOpTag (VecBroadcastOp IntVec 32 W8) = 548 +primOpTag (VecBroadcastOp IntVec 16 W16) = 549 +primOpTag (VecBroadcastOp IntVec 8 W32) = 550 +primOpTag (VecBroadcastOp IntVec 4 W64) = 551 +primOpTag (VecBroadcastOp IntVec 64 W8) = 552 +primOpTag (VecBroadcastOp IntVec 32 W16) = 553 +primOpTag (VecBroadcastOp IntVec 16 W32) = 554 +primOpTag (VecBroadcastOp IntVec 8 W64) = 555 +primOpTag (VecBroadcastOp WordVec 16 W8) = 556 +primOpTag (VecBroadcastOp WordVec 8 W16) = 557 +primOpTag (VecBroadcastOp WordVec 4 W32) = 558 +primOpTag (VecBroadcastOp WordVec 2 W64) = 559 +primOpTag (VecBroadcastOp WordVec 32 W8) = 560 +primOpTag (VecBroadcastOp WordVec 16 W16) = 561 +primOpTag (VecBroadcastOp WordVec 8 W32) = 562 +primOpTag (VecBroadcastOp WordVec 4 W64) = 563 +primOpTag (VecBroadcastOp WordVec 64 W8) = 564 +primOpTag (VecBroadcastOp WordVec 32 W16) = 565 +primOpTag (VecBroadcastOp WordVec 16 W32) = 566 +primOpTag (VecBroadcastOp WordVec 8 W64) = 567 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 568 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 569 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 570 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 571 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 572 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 573 +primOpTag (VecPackOp IntVec 16 W8) = 574 +primOpTag (VecPackOp IntVec 8 W16) = 575 +primOpTag (VecPackOp IntVec 4 W32) = 576 +primOpTag (VecPackOp IntVec 2 W64) = 577 +primOpTag (VecPackOp IntVec 32 W8) = 578 +primOpTag (VecPackOp IntVec 16 W16) = 579 +primOpTag (VecPackOp IntVec 8 W32) = 580 +primOpTag (VecPackOp IntVec 4 W64) = 581 +primOpTag (VecPackOp IntVec 64 W8) = 582 +primOpTag (VecPackOp IntVec 32 W16) = 583 +primOpTag (VecPackOp IntVec 16 W32) = 584 +primOpTag (VecPackOp IntVec 8 W64) = 585 +primOpTag (VecPackOp WordVec 16 W8) = 586 +primOpTag (VecPackOp WordVec 8 W16) = 587 +primOpTag (VecPackOp WordVec 4 W32) = 588 +primOpTag (VecPackOp WordVec 2 W64) = 589 +primOpTag (VecPackOp WordVec 32 W8) = 590 +primOpTag (VecPackOp WordVec 16 W16) = 591 +primOpTag (VecPackOp WordVec 8 W32) = 592 +primOpTag (VecPackOp WordVec 4 W64) = 593 +primOpTag (VecPackOp WordVec 64 W8) = 594 +primOpTag (VecPackOp WordVec 32 W16) = 595 +primOpTag (VecPackOp WordVec 16 W32) = 596 +primOpTag (VecPackOp WordVec 8 W64) = 597 +primOpTag (VecPackOp FloatVec 4 W32) = 598 +primOpTag (VecPackOp FloatVec 2 W64) = 599 +primOpTag (VecPackOp FloatVec 8 W32) = 600 +primOpTag (VecPackOp FloatVec 4 W64) = 601 +primOpTag (VecPackOp FloatVec 16 W32) = 602 +primOpTag (VecPackOp FloatVec 8 W64) = 603 +primOpTag (VecUnpackOp IntVec 16 W8) = 604 +primOpTag (VecUnpackOp IntVec 8 W16) = 605 +primOpTag (VecUnpackOp IntVec 4 W32) = 606 +primOpTag (VecUnpackOp IntVec 2 W64) = 607 +primOpTag (VecUnpackOp IntVec 32 W8) = 608 +primOpTag (VecUnpackOp IntVec 16 W16) = 609 +primOpTag (VecUnpackOp IntVec 8 W32) = 610 +primOpTag (VecUnpackOp IntVec 4 W64) = 611 +primOpTag (VecUnpackOp IntVec 64 W8) = 612 +primOpTag (VecUnpackOp IntVec 32 W16) = 613 +primOpTag (VecUnpackOp IntVec 16 W32) = 614 +primOpTag (VecUnpackOp IntVec 8 W64) = 615 +primOpTag (VecUnpackOp WordVec 16 W8) = 616 +primOpTag (VecUnpackOp WordVec 8 W16) = 617 +primOpTag (VecUnpackOp WordVec 4 W32) = 618 +primOpTag (VecUnpackOp WordVec 2 W64) = 619 +primOpTag (VecUnpackOp WordVec 32 W8) = 620 +primOpTag (VecUnpackOp WordVec 16 W16) = 621 +primOpTag (VecUnpackOp WordVec 8 W32) = 622 +primOpTag (VecUnpackOp WordVec 4 W64) = 623 +primOpTag (VecUnpackOp WordVec 64 W8) = 624 +primOpTag (VecUnpackOp WordVec 32 W16) = 625 +primOpTag (VecUnpackOp WordVec 16 W32) = 626 +primOpTag (VecUnpackOp WordVec 8 W64) = 627 +primOpTag (VecUnpackOp FloatVec 4 W32) = 628 +primOpTag (VecUnpackOp FloatVec 2 W64) = 629 +primOpTag (VecUnpackOp FloatVec 8 W32) = 630 +primOpTag (VecUnpackOp FloatVec 4 W64) = 631 +primOpTag (VecUnpackOp FloatVec 16 W32) = 632 +primOpTag (VecUnpackOp FloatVec 8 W64) = 633 +primOpTag (VecInsertOp IntVec 16 W8) = 634 +primOpTag (VecInsertOp IntVec 8 W16) = 635 +primOpTag (VecInsertOp IntVec 4 W32) = 636 +primOpTag (VecInsertOp IntVec 2 W64) = 637 +primOpTag (VecInsertOp IntVec 32 W8) = 638 +primOpTag (VecInsertOp IntVec 16 W16) = 639 +primOpTag (VecInsertOp IntVec 8 W32) = 640 +primOpTag (VecInsertOp IntVec 4 W64) = 641 +primOpTag (VecInsertOp IntVec 64 W8) = 642 +primOpTag (VecInsertOp IntVec 32 W16) = 643 +primOpTag (VecInsertOp IntVec 16 W32) = 644 +primOpTag (VecInsertOp IntVec 8 W64) = 645 +primOpTag (VecInsertOp WordVec 16 W8) = 646 +primOpTag (VecInsertOp WordVec 8 W16) = 647 +primOpTag (VecInsertOp WordVec 4 W32) = 648 +primOpTag (VecInsertOp WordVec 2 W64) = 649 +primOpTag (VecInsertOp WordVec 32 W8) = 650 +primOpTag (VecInsertOp WordVec 16 W16) = 651 +primOpTag (VecInsertOp WordVec 8 W32) = 652 +primOpTag (VecInsertOp WordVec 4 W64) = 653 +primOpTag (VecInsertOp WordVec 64 W8) = 654 +primOpTag (VecInsertOp WordVec 32 W16) = 655 +primOpTag (VecInsertOp WordVec 16 W32) = 656 +primOpTag (VecInsertOp WordVec 8 W64) = 657 +primOpTag (VecInsertOp FloatVec 4 W32) = 658 +primOpTag (VecInsertOp FloatVec 2 W64) = 659 +primOpTag (VecInsertOp FloatVec 8 W32) = 660 +primOpTag (VecInsertOp FloatVec 4 W64) = 661 +primOpTag (VecInsertOp FloatVec 16 W32) = 662 +primOpTag (VecInsertOp FloatVec 8 W64) = 663 +primOpTag (VecAddOp IntVec 16 W8) = 664 +primOpTag (VecAddOp IntVec 8 W16) = 665 +primOpTag (VecAddOp IntVec 4 W32) = 666 +primOpTag (VecAddOp IntVec 2 W64) = 667 +primOpTag (VecAddOp IntVec 32 W8) = 668 +primOpTag (VecAddOp IntVec 16 W16) = 669 +primOpTag (VecAddOp IntVec 8 W32) = 670 +primOpTag (VecAddOp IntVec 4 W64) = 671 +primOpTag (VecAddOp IntVec 64 W8) = 672 +primOpTag (VecAddOp IntVec 32 W16) = 673 +primOpTag (VecAddOp IntVec 16 W32) = 674 +primOpTag (VecAddOp IntVec 8 W64) = 675 +primOpTag (VecAddOp WordVec 16 W8) = 676 +primOpTag (VecAddOp WordVec 8 W16) = 677 +primOpTag (VecAddOp WordVec 4 W32) = 678 +primOpTag (VecAddOp WordVec 2 W64) = 679 +primOpTag (VecAddOp WordVec 32 W8) = 680 +primOpTag (VecAddOp WordVec 16 W16) = 681 +primOpTag (VecAddOp WordVec 8 W32) = 682 +primOpTag (VecAddOp WordVec 4 W64) = 683 +primOpTag (VecAddOp WordVec 64 W8) = 684 +primOpTag (VecAddOp WordVec 32 W16) = 685 +primOpTag (VecAddOp WordVec 16 W32) = 686 +primOpTag (VecAddOp WordVec 8 W64) = 687 +primOpTag (VecAddOp FloatVec 4 W32) = 688 +primOpTag (VecAddOp FloatVec 2 W64) = 689 +primOpTag (VecAddOp FloatVec 8 W32) = 690 +primOpTag (VecAddOp FloatVec 4 W64) = 691 +primOpTag (VecAddOp FloatVec 16 W32) = 692 +primOpTag (VecAddOp FloatVec 8 W64) = 693 +primOpTag (VecSubOp IntVec 16 W8) = 694 +primOpTag (VecSubOp IntVec 8 W16) = 695 +primOpTag (VecSubOp IntVec 4 W32) = 696 +primOpTag (VecSubOp IntVec 2 W64) = 697 +primOpTag (VecSubOp IntVec 32 W8) = 698 +primOpTag (VecSubOp IntVec 16 W16) = 699 +primOpTag (VecSubOp IntVec 8 W32) = 700 +primOpTag (VecSubOp IntVec 4 W64) = 701 +primOpTag (VecSubOp IntVec 64 W8) = 702 +primOpTag (VecSubOp IntVec 32 W16) = 703 +primOpTag (VecSubOp IntVec 16 W32) = 704 +primOpTag (VecSubOp IntVec 8 W64) = 705 +primOpTag (VecSubOp WordVec 16 W8) = 706 +primOpTag (VecSubOp WordVec 8 W16) = 707 +primOpTag (VecSubOp WordVec 4 W32) = 708 +primOpTag (VecSubOp WordVec 2 W64) = 709 +primOpTag (VecSubOp WordVec 32 W8) = 710 +primOpTag (VecSubOp WordVec 16 W16) = 711 +primOpTag (VecSubOp WordVec 8 W32) = 712 +primOpTag (VecSubOp WordVec 4 W64) = 713 +primOpTag (VecSubOp WordVec 64 W8) = 714 +primOpTag (VecSubOp WordVec 32 W16) = 715 +primOpTag (VecSubOp WordVec 16 W32) = 716 +primOpTag (VecSubOp WordVec 8 W64) = 717 +primOpTag (VecSubOp FloatVec 4 W32) = 718 +primOpTag (VecSubOp FloatVec 2 W64) = 719 +primOpTag (VecSubOp FloatVec 8 W32) = 720 +primOpTag (VecSubOp FloatVec 4 W64) = 721 +primOpTag (VecSubOp FloatVec 16 W32) = 722 +primOpTag (VecSubOp FloatVec 8 W64) = 723 +primOpTag (VecMulOp IntVec 16 W8) = 724 +primOpTag (VecMulOp IntVec 8 W16) = 725 +primOpTag (VecMulOp IntVec 4 W32) = 726 +primOpTag (VecMulOp IntVec 2 W64) = 727 +primOpTag (VecMulOp IntVec 32 W8) = 728 +primOpTag (VecMulOp IntVec 16 W16) = 729 +primOpTag (VecMulOp IntVec 8 W32) = 730 +primOpTag (VecMulOp IntVec 4 W64) = 731 +primOpTag (VecMulOp IntVec 64 W8) = 732 +primOpTag (VecMulOp IntVec 32 W16) = 733 +primOpTag (VecMulOp IntVec 16 W32) = 734 +primOpTag (VecMulOp IntVec 8 W64) = 735 +primOpTag (VecMulOp WordVec 16 W8) = 736 +primOpTag (VecMulOp WordVec 8 W16) = 737 +primOpTag (VecMulOp WordVec 4 W32) = 738 +primOpTag (VecMulOp WordVec 2 W64) = 739 +primOpTag (VecMulOp WordVec 32 W8) = 740 +primOpTag (VecMulOp WordVec 16 W16) = 741 +primOpTag (VecMulOp WordVec 8 W32) = 742 +primOpTag (VecMulOp WordVec 4 W64) = 743 +primOpTag (VecMulOp WordVec 64 W8) = 744 +primOpTag (VecMulOp WordVec 32 W16) = 745 +primOpTag (VecMulOp WordVec 16 W32) = 746 +primOpTag (VecMulOp WordVec 8 W64) = 747 +primOpTag (VecMulOp FloatVec 4 W32) = 748 +primOpTag (VecMulOp FloatVec 2 W64) = 749 +primOpTag (VecMulOp FloatVec 8 W32) = 750 +primOpTag (VecMulOp FloatVec 4 W64) = 751 +primOpTag (VecMulOp FloatVec 16 W32) = 752 +primOpTag (VecMulOp FloatVec 8 W64) = 753 +primOpTag (VecDivOp FloatVec 4 W32) = 754 +primOpTag (VecDivOp FloatVec 2 W64) = 755 +primOpTag (VecDivOp FloatVec 8 W32) = 756 +primOpTag (VecDivOp FloatVec 4 W64) = 757 +primOpTag (VecDivOp FloatVec 16 W32) = 758 +primOpTag (VecDivOp FloatVec 8 W64) = 759 +primOpTag (VecQuotOp IntVec 16 W8) = 760 +primOpTag (VecQuotOp IntVec 8 W16) = 761 +primOpTag (VecQuotOp IntVec 4 W32) = 762 +primOpTag (VecQuotOp IntVec 2 W64) = 763 +primOpTag (VecQuotOp IntVec 32 W8) = 764 +primOpTag (VecQuotOp IntVec 16 W16) = 765 +primOpTag (VecQuotOp IntVec 8 W32) = 766 +primOpTag (VecQuotOp IntVec 4 W64) = 767 +primOpTag (VecQuotOp IntVec 64 W8) = 768 +primOpTag (VecQuotOp IntVec 32 W16) = 769 +primOpTag (VecQuotOp IntVec 16 W32) = 770 +primOpTag (VecQuotOp IntVec 8 W64) = 771 +primOpTag (VecQuotOp WordVec 16 W8) = 772 +primOpTag (VecQuotOp WordVec 8 W16) = 773 +primOpTag (VecQuotOp WordVec 4 W32) = 774 +primOpTag (VecQuotOp WordVec 2 W64) = 775 +primOpTag (VecQuotOp WordVec 32 W8) = 776 +primOpTag (VecQuotOp WordVec 16 W16) = 777 +primOpTag (VecQuotOp WordVec 8 W32) = 778 +primOpTag (VecQuotOp WordVec 4 W64) = 779 +primOpTag (VecQuotOp WordVec 64 W8) = 780 +primOpTag (VecQuotOp WordVec 32 W16) = 781 +primOpTag (VecQuotOp WordVec 16 W32) = 782 +primOpTag (VecQuotOp WordVec 8 W64) = 783 +primOpTag (VecRemOp IntVec 16 W8) = 784 +primOpTag (VecRemOp IntVec 8 W16) = 785 +primOpTag (VecRemOp IntVec 4 W32) = 786 +primOpTag (VecRemOp IntVec 2 W64) = 787 +primOpTag (VecRemOp IntVec 32 W8) = 788 +primOpTag (VecRemOp IntVec 16 W16) = 789 +primOpTag (VecRemOp IntVec 8 W32) = 790 +primOpTag (VecRemOp IntVec 4 W64) = 791 +primOpTag (VecRemOp IntVec 64 W8) = 792 +primOpTag (VecRemOp IntVec 32 W16) = 793 +primOpTag (VecRemOp IntVec 16 W32) = 794 +primOpTag (VecRemOp IntVec 8 W64) = 795 +primOpTag (VecRemOp WordVec 16 W8) = 796 +primOpTag (VecRemOp WordVec 8 W16) = 797 +primOpTag (VecRemOp WordVec 4 W32) = 798 +primOpTag (VecRemOp WordVec 2 W64) = 799 +primOpTag (VecRemOp WordVec 32 W8) = 800 +primOpTag (VecRemOp WordVec 16 W16) = 801 +primOpTag (VecRemOp WordVec 8 W32) = 802 +primOpTag (VecRemOp WordVec 4 W64) = 803 +primOpTag (VecRemOp WordVec 64 W8) = 804 +primOpTag (VecRemOp WordVec 32 W16) = 805 +primOpTag (VecRemOp WordVec 16 W32) = 806 +primOpTag (VecRemOp WordVec 8 W64) = 807 +primOpTag (VecNegOp IntVec 16 W8) = 808 +primOpTag (VecNegOp IntVec 8 W16) = 809 +primOpTag (VecNegOp IntVec 4 W32) = 810 +primOpTag (VecNegOp IntVec 2 W64) = 811 +primOpTag (VecNegOp IntVec 32 W8) = 812 +primOpTag (VecNegOp IntVec 16 W16) = 813 +primOpTag (VecNegOp IntVec 8 W32) = 814 +primOpTag (VecNegOp IntVec 4 W64) = 815 +primOpTag (VecNegOp IntVec 64 W8) = 816 +primOpTag (VecNegOp IntVec 32 W16) = 817 +primOpTag (VecNegOp IntVec 16 W32) = 818 +primOpTag (VecNegOp IntVec 8 W64) = 819 +primOpTag (VecNegOp FloatVec 4 W32) = 820 +primOpTag (VecNegOp FloatVec 2 W64) = 821 +primOpTag (VecNegOp FloatVec 8 W32) = 822 +primOpTag (VecNegOp FloatVec 4 W64) = 823 +primOpTag (VecNegOp FloatVec 16 W32) = 824 +primOpTag (VecNegOp FloatVec 8 W64) = 825 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 826 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 827 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 828 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 829 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 830 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 831 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 832 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 833 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 834 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 835 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 836 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 837 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 838 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 839 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 840 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 841 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 842 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 843 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 844 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 845 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 846 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 847 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 848 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 849 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 850 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 851 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 852 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 853 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 854 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 855 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 856 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 857 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 858 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 859 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 860 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 861 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 862 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 863 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 864 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 865 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 866 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 867 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 868 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 869 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 870 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 871 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 872 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 873 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 874 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 875 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 876 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 877 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 878 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 879 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 880 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 881 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 882 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 883 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 884 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 885 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 886 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 887 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 888 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 889 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 890 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 891 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 892 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 893 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 894 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 895 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 896 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 897 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 898 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 899 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 900 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 901 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 902 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 903 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 904 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 905 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 906 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 907 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 908 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 909 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 910 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 911 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 912 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 913 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 914 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 915 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 916 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 917 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 918 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 919 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 920 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 921 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 922 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 923 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 924 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 925 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 926 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 927 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 928 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 929 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 930 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 931 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 932 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 933 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 934 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 935 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 936 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 937 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 938 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 939 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 940 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 941 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 942 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 943 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 944 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 945 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 946 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 947 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 948 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 949 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 950 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 951 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 952 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 953 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 954 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 955 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 956 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 957 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 958 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 959 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 960 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 961 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 962 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 963 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 964 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 965 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 966 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 967 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 968 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 969 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 970 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 971 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 972 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 973 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 974 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 975 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 976 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 977 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 978 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 979 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 980 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 981 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 982 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 983 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 984 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 985 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 986 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 987 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 988 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 989 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 990 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 991 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 992 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 993 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 994 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 995 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 996 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 997 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 998 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 999 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1000 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1001 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1002 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1003 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1004 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1005 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1006 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1007 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1008 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1009 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1010 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1011 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1012 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1013 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1014 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1015 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1016 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1017 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1018 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1019 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1020 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1021 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1022 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1023 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1024 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1025 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1026 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1027 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1028 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1029 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1030 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1031 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1032 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1033 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1034 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1035 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1036 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1037 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1038 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1039 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1040 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1041 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1042 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1043 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1044 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1045 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1046 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1047 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1048 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1049 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1050 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1051 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1052 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1053 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1054 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1055 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1056 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1057 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1058 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1059 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1060 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1061 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1062 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1063 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1064 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1065 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1066 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1067 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1068 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1069 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1070 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1071 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1072 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1073 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1074 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1075 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1076 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1077 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1078 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1079 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1080 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1081 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1082 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1083 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1084 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1085 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1086 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1087 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1088 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1089 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1090 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1091 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1092 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1093 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1094 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1095 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1096 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1097 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1098 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1099 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1100 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1101 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1102 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1103 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1104 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1105 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1106 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1107 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1108 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1109 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1110 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1111 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1112 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1113 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1114 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1115 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1116 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1117 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1118 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1119 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1120 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1121 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1122 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1123 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1124 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1125 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1126 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1127 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1128 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1129 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1130 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1131 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1132 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1133 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1134 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1135 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1136 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1137 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1138 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1139 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1140 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1141 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1142 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1143 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1144 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1145 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1146 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1147 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1148 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1149 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1150 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1151 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1152 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1153 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1154 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1155 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1156 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1157 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1158 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1159 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1160 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1161 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1162 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1163 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1164 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1165 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1166 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1167 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1168 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1169 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1170 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1171 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1172 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1173 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1174 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1175 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1176 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1177 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1178 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1179 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1180 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1181 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1182 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1183 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1184 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1185 +primOpTag PrefetchByteArrayOp3 = 1186 +primOpTag PrefetchMutableByteArrayOp3 = 1187 +primOpTag PrefetchAddrOp3 = 1188 +primOpTag PrefetchValueOp3 = 1189 +primOpTag PrefetchByteArrayOp2 = 1190 +primOpTag PrefetchMutableByteArrayOp2 = 1191 +primOpTag PrefetchAddrOp2 = 1192 +primOpTag PrefetchValueOp2 = 1193 +primOpTag PrefetchByteArrayOp1 = 1194 +primOpTag PrefetchMutableByteArrayOp1 = 1195 +primOpTag PrefetchAddrOp1 = 1196 +primOpTag PrefetchValueOp1 = 1197 +primOpTag PrefetchByteArrayOp0 = 1198 +primOpTag PrefetchMutableByteArrayOp0 = 1199 +primOpTag PrefetchAddrOp0 = 1200 +primOpTag PrefetchValueOp0 = 1201 diff --git a/ghc-lib/stage1/lib/platformConstants b/ghc-lib/stage1/lib/platformConstants --- a/ghc-lib/stage1/lib/platformConstants +++ b/ghc-lib/stage1/lib/platformConstants @@ -101,7 +101,7 @@ , pc_MAX_SPEC_AP_SIZE = 7 , pc_MIN_PAYLOAD_SIZE = 1 , pc_MIN_INTLIKE = -16 - , pc_MAX_INTLIKE = 16 + , pc_MAX_INTLIKE = 255 , pc_MIN_CHARLIKE = 0 , pc_MAX_CHARLIKE = 255 , pc_MUT_ARR_PTRS_CARD_BITS = 7 diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings --- a/ghc-lib/stage1/lib/settings +++ b/ghc-lib/stage1/lib/settings @@ -31,6 +31,7 @@ ,("target has subsections via symbols", "True") ,("target has RTS linker", "YES") ,("Unregisterised", "NO") +,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang") diff --git a/includes/Cmm.h b/includes/Cmm.h deleted file mode 100644 --- a/includes/Cmm.h +++ /dev/null @@ -1,946 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The University of Glasgow 2004-2013 - * - * This file is included at the top of all .cmm source files (and - * *only* .cmm files). It defines a collection of useful macros for - * making .cmm code a bit less error-prone to write, and a bit easier - * on the eye for the reader. - * - * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y. - * - * Accessing fields of structures defined in the RTS header files is - * done via automatically-generated macros in DerivedConstants.h. For - * example, where previously we used - * - * CurrentTSO->what_next = x - * - * in C-- we now use - * - * StgTSO_what_next(CurrentTSO) = x - * - * where the StgTSO_what_next() macro is automatically generated by - * mkDerivedConstants.c. If you need to access a field that doesn't - * already have a macro, edit that file (it's pretty self-explanatory). - * - * -------------------------------------------------------------------------- */ - -#pragma once - -/* - * In files that are included into both C and C-- (and perhaps - * Haskell) sources, we sometimes need to conditionally compile bits - * depending on the language. CMINUSMINUS==1 in .cmm sources: - */ -#define CMINUSMINUS 1 - -#include "ghcconfig.h" - -/* ----------------------------------------------------------------------------- - Types - - The following synonyms for C-- types are declared here: - - I8, I16, I32, I64 MachRep-style names for convenience - - W_ is shorthand for the word type (== StgWord) - F_ shorthand for float (F_ == StgFloat == C's float) - D_ shorthand for double (D_ == StgDouble == C's double) - - CInt has the same size as an int in C on this platform - CLong has the same size as a long in C on this platform - CBool has the same size as a bool in C on this platform - - --------------------------------------------------------------------------- */ - -#define I8 bits8 -#define I16 bits16 -#define I32 bits32 -#define I64 bits64 -#define P_ gcptr - -#if SIZEOF_VOID_P == 4 -#define W_ bits32 -/* Maybe it's better to include MachDeps.h */ -#define TAG_BITS 2 -#elif SIZEOF_VOID_P == 8 -#define W_ bits64 -/* Maybe it's better to include MachDeps.h */ -#define TAG_BITS 3 -#else -#error Unknown word size -#endif - -/* - * The RTS must sometimes UNTAG a pointer before dereferencing it. - * See the wiki page commentary/rts/haskell-execution/pointer-tagging - */ -#define TAG_MASK ((1 << TAG_BITS) - 1) -#define UNTAG(p) (p & ~TAG_MASK) -#define GETTAG(p) (p & TAG_MASK) - -#if SIZEOF_INT == 4 -#define CInt bits32 -#elif SIZEOF_INT == 8 -#define CInt bits64 -#else -#error Unknown int size -#endif - -#if SIZEOF_LONG == 4 -#define CLong bits32 -#elif SIZEOF_LONG == 8 -#define CLong bits64 -#else -#error Unknown long size -#endif - -#define CBool bits8 - -#define F_ float32 -#define D_ float64 -#define L_ bits64 -#define V16_ bits128 -#define V32_ bits256 -#define V64_ bits512 - -#define SIZEOF_StgDouble 8 -#define SIZEOF_StgWord64 8 - -/* ----------------------------------------------------------------------------- - Misc useful stuff - -------------------------------------------------------------------------- */ - -#define ccall foreign "C" - -#define NULL (0::W_) - -#define STRING(name,str) \ - section "rodata" { \ - name : bits8[] str; \ - } \ - -#if defined(TABLES_NEXT_TO_CODE) -#define RET_LBL(f) f##_info -#else -#define RET_LBL(f) f##_ret -#endif - -#if defined(TABLES_NEXT_TO_CODE) -#define ENTRY_LBL(f) f##_info -#else -#define ENTRY_LBL(f) f##_entry -#endif - -/* ----------------------------------------------------------------------------- - Byte/word macros - - Everything in C-- is in byte offsets (well, most things). We use - some macros to allow us to express offsets in words and to try to - avoid byte/word confusion. - -------------------------------------------------------------------------- */ - -#define SIZEOF_W SIZEOF_VOID_P -#define W_MASK (SIZEOF_W-1) - -#if SIZEOF_W == 4 -#define W_SHIFT 2 -#elif SIZEOF_W == 8 -#define W_SHIFT 3 -#endif - -/* Converting quantities of words to bytes */ -#define WDS(n) ((n)*SIZEOF_W) - -/* - * Converting quantities of bytes to words - * NB. these work on *unsigned* values only - */ -#define BYTES_TO_WDS(n) ((n) / SIZEOF_W) -#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W) - -/* - * TO_W_(n) and TO_ZXW_(n) convert n to W_ type from a smaller type, - * with and without sign extension respectively - */ -#if SIZEOF_W == 4 -#define TO_I64(x) %sx64(x) -#define TO_W_(x) %sx32(x) -#define TO_ZXW_(x) %zx32(x) -#define HALF_W_(x) %lobits16(x) -#elif SIZEOF_W == 8 -#define TO_I64(x) (x) -#define TO_W_(x) %sx64(x) -#define TO_ZXW_(x) %zx64(x) -#define HALF_W_(x) %lobits32(x) -#endif - -#if SIZEOF_INT == 4 && SIZEOF_W == 8 -#define W_TO_INT(x) %lobits32(x) -#elif SIZEOF_INT == SIZEOF_W -#define W_TO_INT(x) (x) -#endif - -#if SIZEOF_LONG == 4 && SIZEOF_W == 8 -#define W_TO_LONG(x) %lobits32(x) -#elif SIZEOF_LONG == SIZEOF_W -#define W_TO_LONG(x) (x) -#endif - -/* ----------------------------------------------------------------------------- - Atomic memory operations. - -------------------------------------------------------------------------- */ - -#if SIZEOF_W == 4 -#define cmpxchgW cmpxchg32 -#elif SIZEOF_W == 8 -#define cmpxchgW cmpxchg64 -#endif - -/* ----------------------------------------------------------------------------- - Heap/stack access, and adjusting the heap/stack pointers. - -------------------------------------------------------------------------- */ - -#define Sp(n) W_[Sp + WDS(n)] -#define Hp(n) W_[Hp + WDS(n)] - -#define Sp_adj(n) Sp = Sp + WDS(n) /* pronounced "spadge" */ -#define Hp_adj(n) Hp = Hp + WDS(n) - -/* ----------------------------------------------------------------------------- - Assertions and Debuggery - -------------------------------------------------------------------------- */ - -#if defined(DEBUG) -#define ASSERT(predicate) \ - if (predicate) { \ - /*null*/; \ - } else { \ - foreign "C" _assertFail(__FILE__, __LINE__) never returns; \ - } -#else -#define ASSERT(p) /* nothing */ -#endif - -#if defined(DEBUG) -#define DEBUG_ONLY(s) s -#else -#define DEBUG_ONLY(s) /* nothing */ -#endif - -/* - * The IF_DEBUG macro is useful for debug messages that depend on one - * of the RTS debug options. For example: - * - * IF_DEBUG(RtsFlags_DebugFlags_apply, - * foreign "C" fprintf(stderr, stg_ap_0_ret_str)); - * - * Note the syntax is slightly different to the C version of this macro. - */ -#if defined(DEBUG) -#define IF_DEBUG(c,s) if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; } -#else -#define IF_DEBUG(c,s) /* nothing */ -#endif - -/* ----------------------------------------------------------------------------- - Entering - - It isn't safe to "enter" every closure. Functions in particular - have no entry code as such; their entry point contains the code to - apply the function. - - ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES, - but switch doesn't allow us to use exprs there yet. - - If R1 points to a tagged object it points either to - * A constructor. - * A function with arity <= TAG_MASK. - In both cases the right thing to do is to return. - Note: it is rather lucky that we can use the tag bits to do this - for both objects. Maybe it points to a brittle design? - - Indirections can contain tagged pointers, so their tag is checked. - -------------------------------------------------------------------------- */ - -#if defined(PROFILING) - -// When profiling, we cannot shortcut ENTER() by checking the tag, -// because LDV profiling relies on entering closures to mark them as -// "used". - -#define LOAD_INFO(ret,x) \ - info = %INFO_PTR(UNTAG(x)); - -#define UNTAG_IF_PROF(x) UNTAG(x) - -#else - -#define LOAD_INFO(ret,x) \ - if (GETTAG(x) != 0) { \ - ret(x); \ - } \ - info = %INFO_PTR(x); - -#define UNTAG_IF_PROF(x) (x) /* already untagged */ - -#endif - -// We need two versions of ENTER(): -// - ENTER(x) takes the closure as an argument and uses return(), -// for use in civilized code where the stack is handled by GHC -// -// - ENTER_NOSTACK() where the closure is in R1, and returns are -// explicit jumps, for use when we are doing the stack management -// ourselves. - -#if defined(PROFILING) -// See Note [Evaluating functions with profiling] in rts/Apply.cmm -#define ENTER(x) jump stg_ap_0_fast(x); -#else -#define ENTER(x) ENTER_(return,x) -#endif - -#define ENTER_R1() ENTER_(RET_R1,R1) - -#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] - -#define ENTER_(ret,x) \ - again: \ - W_ info; \ - LOAD_INFO(ret,x) \ - /* See Note [Heap memory barriers] in SMP.h */ \ - prim_read_barrier; \ - switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \ - (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { \ - case \ - IND, \ - IND_STATIC: \ - { \ - x = StgInd_indirectee(x); \ - goto again; \ - } \ - case \ - FUN, \ - FUN_1_0, \ - FUN_0_1, \ - FUN_2_0, \ - FUN_1_1, \ - FUN_0_2, \ - FUN_STATIC, \ - BCO, \ - PAP: \ - { \ - ret(x); \ - } \ - default: \ - { \ - x = UNTAG_IF_PROF(x); \ - jump %ENTRY_CODE(info) (x); \ - } \ - } - -// The FUN cases almost never happen: a pointer to a non-static FUN -// should always be tagged. This unfortunately isn't true for the -// interpreter right now, which leaves untagged FUNs on the stack. - -/* ----------------------------------------------------------------------------- - Constants. - -------------------------------------------------------------------------- */ - -#include "rts/Constants.h" -#include "DerivedConstants.h" -#include "rts/storage/ClosureTypes.h" -#include "rts/storage/FunTypes.h" -#include "rts/OSThreads.h" - -/* - * Need MachRegs, because some of the RTS code is conditionally - * compiled based on REG_R1, REG_R2, etc. - */ -#include "stg/RtsMachRegs.h" - -#include "rts/prof/LDV.h" - -#undef BLOCK_SIZE -#undef MBLOCK_SIZE -#include "rts/storage/Block.h" /* For Bdescr() */ - - -#define MyCapability() (BaseReg - OFFSET_Capability_r) - -/* ------------------------------------------------------------------------- - Info tables - ------------------------------------------------------------------------- */ - -#if defined(PROFILING) -#define PROF_HDR_FIELDS(w_,hdr1,hdr2) \ - w_ hdr1, \ - w_ hdr2, -#else -#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */ -#endif - -/* ------------------------------------------------------------------------- - Allocation and garbage collection - ------------------------------------------------------------------------- */ - -/* - * ALLOC_PRIM is for allocating memory on the heap for a primitive - * object. It is used all over PrimOps.cmm. - * - * We make the simplifying assumption that the "admin" part of a - * primitive closure is just the header when calculating sizes for - * ticky-ticky. It's not clear whether eg. the size field of an array - * should be counted as "admin", or the various fields of a BCO. - */ -#define ALLOC_PRIM(bytes) \ - HP_CHK_GEN_TICKY(bytes); \ - TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \ - CCCS_ALLOC(bytes); - -#define HEAP_CHECK(bytes,failure) \ - TICK_BUMP(HEAP_CHK_ctr); \ - Hp = Hp + (bytes); \ - if (Hp > HpLim) { HpAlloc = (bytes); failure; } \ - TICK_ALLOC_HEAP_NOCTR(bytes); - -#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure) \ - HEAP_CHECK(bytes,failure) \ - TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \ - CCCS_ALLOC(bytes); - -#define ALLOC_PRIM_(bytes,fun) \ - ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun)); - -#define ALLOC_PRIM_P(bytes,fun,arg) \ - ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg)); - -#define ALLOC_PRIM_N(bytes,fun,arg) \ - ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg)); - -/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */ -#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS) - -#define HP_CHK_GEN_TICKY(bytes) \ - HP_CHK_GEN(bytes); \ - TICK_ALLOC_HEAP_NOCTR(bytes); - -#define HP_CHK_P(bytes, fun, arg) \ - HEAP_CHECK(bytes, GC_PRIM_P(fun,arg)) - -// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed? -// -NSF March 2013 -#define ALLOC_P_TICKY(bytes, fun, arg) \ - HP_CHK_P(bytes); \ - TICK_ALLOC_HEAP_NOCTR(bytes); - -#define CHECK_GC() \ - (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) - -// allocate() allocates from the nursery, so we check to see -// whether the nursery is nearly empty in any function that uses -// allocate() - this includes many of the primops. -// -// HACK alert: the __L__ stuff is here to coax the common-block -// eliminator into commoning up the call stg_gc_noregs() with the same -// code that gets generated by a STK_CHK_GEN() in the same proc. We -// also need an if (0) { goto __L__; } so that the __L__ label isn't -// optimised away by the control-flow optimiser prior to common-block -// elimination (it will be optimised away later). -// -// This saves some code in gmp-wrappers.cmm where we have lots of -// MAYBE_GC() in the same proc as STK_CHK_GEN(). -// -#define MAYBE_GC(retry) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - goto __L__; \ - __L__: \ - call stg_gc_noregs(); \ - goto retry; \ - } \ - if (0) { goto __L__; } - -#define GC_PRIM(fun) \ - jump stg_gc_prim(fun); - -// Version of GC_PRIM for use in low-level Cmm. We can call -// stg_gc_prim, because it takes one argument and therefore has a -// platform-independent calling convention (Note [Syntax of .cmm -// files] in CmmParse.y). -#define GC_PRIM_LL(fun) \ - R1 = fun; \ - jump stg_gc_prim [R1]; - -// We pass the fun as the second argument, because the arg is -// usually already in the first argument position (R1), so this -// avoids moving it to a different register / stack slot. -#define GC_PRIM_N(fun,arg) \ - jump stg_gc_prim_n(arg,fun); - -#define GC_PRIM_P(fun,arg) \ - jump stg_gc_prim_p(arg,fun); - -#define GC_PRIM_P_LL(fun,arg) \ - R1 = arg; \ - R2 = fun; \ - jump stg_gc_prim_p_ll [R1,R2]; - -#define GC_PRIM_PP(fun,arg1,arg2) \ - jump stg_gc_prim_pp(arg1,arg2,fun); - -#define MAYBE_GC_(fun) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM(fun) \ - } - -#define MAYBE_GC_N(fun,arg) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM_N(fun,arg) \ - } - -#define MAYBE_GC_P(fun,arg) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM_P(fun,arg) \ - } - -#define MAYBE_GC_PP(fun,arg1,arg2) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM_PP(fun,arg1,arg2) \ - } - -#define STK_CHK_LL(n, fun) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - GC_PRIM_LL(fun) \ - } - -#define STK_CHK_P_LL(n, fun, arg) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - GC_PRIM_P_LL(fun,arg) \ - } - -#define STK_CHK_PP(n, fun, arg1, arg2) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - GC_PRIM_PP(fun,arg1,arg2) \ - } - -#define STK_CHK_ENTER(n, closure) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - jump __stg_gc_enter_1(closure); \ - } - -// A funky heap check used by AutoApply.cmm - -#define HP_CHK_NP_ASSIGN_SP0(size,f) \ - HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];) - -/* ----------------------------------------------------------------------------- - Closure headers - -------------------------------------------------------------------------- */ - -/* - * This is really ugly, since we don't do the rest of StgHeader this - * way. The problem is that values from DerivedConstants.h cannot be - * dependent on the way (SMP, PROF etc.). For SIZEOF_StgHeader we get - * the value from GHC, but it seems like too much trouble to do that - * for StgThunkHeader. - */ -#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader - -#define StgThunk_payload(__ptr__,__ix__) \ - W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)] - -/* ----------------------------------------------------------------------------- - Closures - -------------------------------------------------------------------------- */ - -/* The offset of the payload of an array */ -#define BYTE_ARR_CTS(arr) ((arr) + SIZEOF_StgArrBytes) - -/* The number of words allocated in an array payload */ -#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr)) - -/* Getting/setting the info pointer of a closure */ -#define SET_INFO(p,info) StgHeader_info(p) = info -#define GET_INFO(p) StgHeader_info(p) - -/* Determine the size of an ordinary closure from its info table */ -#define sizeW_fromITBL(itbl) \ - SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl)) - -/* NB. duplicated from InfoTables.h! */ -#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK) -#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT) - -/* Debugging macros */ -#define LOOKS_LIKE_INFO_PTR(p) \ - ((p) != NULL && \ - LOOKS_LIKE_INFO_PTR_NOT_NULL(p)) - -#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \ - ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \ - (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES)) - -#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) - -/* - * The layout of the StgFunInfoExtra part of an info table changes - * depending on TABLES_NEXT_TO_CODE. So we define field access - * macros which use the appropriate version here: - */ -#if defined(TABLES_NEXT_TO_CODE) -/* - * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset - * instead of the normal pointer. - */ - -#define StgFunInfoExtra_slow_apply(fun_info) \ - (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info)) \ - + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable) - -#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraRev_fun_type(i) -#define StgFunInfoExtra_arity(i) StgFunInfoExtraRev_arity(i) -#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraRev_bitmap(i) -#else -#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i) -#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraFwd_fun_type(i) -#define StgFunInfoExtra_arity(i) StgFunInfoExtraFwd_arity(i) -#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i) -#endif - -#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1) -#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS) -#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS) -#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n)) - -#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG)) -#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size) -#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr") -#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n) -#else -#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */ -#define OVERWRITING_CLOSURE(c) /* nothing */ -#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */ -#endif - -// Memory barriers. -// For discussion of how these are used to fence heap object -// accesses see Note [Heap memory barriers] in SMP.h. -#if defined(THREADED_RTS) -#define prim_read_barrier prim %read_barrier() -#else -#define prim_read_barrier /* nothing */ -#endif -#if defined(THREADED_RTS) -#define prim_write_barrier prim %write_barrier() -#else -#define prim_write_barrier /* nothing */ -#endif - -/* ----------------------------------------------------------------------------- - Ticky macros - -------------------------------------------------------------------------- */ - -#if defined(TICKY_TICKY) -#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n -#else -#define TICK_BUMP_BY(ctr,n) /* nothing */ -#endif - -#define TICK_BUMP(ctr) TICK_BUMP_BY(ctr,1) - -#define TICK_ENT_DYN_IND() TICK_BUMP(ENT_DYN_IND_ctr) -#define TICK_ENT_DYN_THK() TICK_BUMP(ENT_DYN_THK_ctr) -#define TICK_ENT_VIA_NODE() TICK_BUMP(ENT_VIA_NODE_ctr) -#define TICK_ENT_STATIC_IND() TICK_BUMP(ENT_STATIC_IND_ctr) -#define TICK_ENT_PERM_IND() TICK_BUMP(ENT_PERM_IND_ctr) -#define TICK_ENT_PAP() TICK_BUMP(ENT_PAP_ctr) -#define TICK_ENT_AP() TICK_BUMP(ENT_AP_ctr) -#define TICK_ENT_AP_STACK() TICK_BUMP(ENT_AP_STACK_ctr) -#define TICK_ENT_BH() TICK_BUMP(ENT_BH_ctr) -#define TICK_ENT_LNE() TICK_BUMP(ENT_LNE_ctr) -#define TICK_UNKNOWN_CALL() TICK_BUMP(UNKNOWN_CALL_ctr) -#define TICK_UPDF_PUSHED() TICK_BUMP(UPDF_PUSHED_ctr) -#define TICK_CATCHF_PUSHED() TICK_BUMP(CATCHF_PUSHED_ctr) -#define TICK_UPDF_OMITTED() TICK_BUMP(UPDF_OMITTED_ctr) -#define TICK_UPD_NEW_IND() TICK_BUMP(UPD_NEW_IND_ctr) -#define TICK_UPD_NEW_PERM_IND() TICK_BUMP(UPD_NEW_PERM_IND_ctr) -#define TICK_UPD_OLD_IND() TICK_BUMP(UPD_OLD_IND_ctr) -#define TICK_UPD_OLD_PERM_IND() TICK_BUMP(UPD_OLD_PERM_IND_ctr) - -#define TICK_SLOW_CALL_FUN_TOO_FEW() TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr) -#define TICK_SLOW_CALL_FUN_CORRECT() TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr) -#define TICK_SLOW_CALL_FUN_TOO_MANY() TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr) -#define TICK_SLOW_CALL_PAP_TOO_FEW() TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr) -#define TICK_SLOW_CALL_PAP_CORRECT() TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr) -#define TICK_SLOW_CALL_PAP_TOO_MANY() TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr) - -#define TICK_SLOW_CALL_fast_v16() TICK_BUMP(SLOW_CALL_fast_v16_ctr) -#define TICK_SLOW_CALL_fast_v() TICK_BUMP(SLOW_CALL_fast_v_ctr) -#define TICK_SLOW_CALL_fast_p() TICK_BUMP(SLOW_CALL_fast_p_ctr) -#define TICK_SLOW_CALL_fast_pv() TICK_BUMP(SLOW_CALL_fast_pv_ctr) -#define TICK_SLOW_CALL_fast_pp() TICK_BUMP(SLOW_CALL_fast_pp_ctr) -#define TICK_SLOW_CALL_fast_ppv() TICK_BUMP(SLOW_CALL_fast_ppv_ctr) -#define TICK_SLOW_CALL_fast_ppp() TICK_BUMP(SLOW_CALL_fast_ppp_ctr) -#define TICK_SLOW_CALL_fast_pppv() TICK_BUMP(SLOW_CALL_fast_pppv_ctr) -#define TICK_SLOW_CALL_fast_pppp() TICK_BUMP(SLOW_CALL_fast_pppp_ctr) -#define TICK_SLOW_CALL_fast_ppppp() TICK_BUMP(SLOW_CALL_fast_ppppp_ctr) -#define TICK_SLOW_CALL_fast_pppppp() TICK_BUMP(SLOW_CALL_fast_pppppp_ctr) -#define TICK_VERY_SLOW_CALL() TICK_BUMP(VERY_SLOW_CALL_ctr) - -/* NOTE: TICK_HISTO_BY and TICK_HISTO - currently have no effect. - The old code for it didn't typecheck and I - just commented it out to get ticky to work. - - krc 1/2007 */ - -#define TICK_HISTO_BY(histo,n,i) /* nothing */ - -#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1) - -/* An unboxed tuple with n components. */ -#define TICK_RET_UNBOXED_TUP(n) \ - TICK_BUMP(RET_UNBOXED_TUP_ctr++); \ - TICK_HISTO(RET_UNBOXED_TUP,n) - -/* - * A slow call with n arguments. In the unevald case, this call has - * already been counted once, so don't count it again. - */ -#define TICK_SLOW_CALL(n) \ - TICK_BUMP(SLOW_CALL_ctr); \ - TICK_HISTO(SLOW_CALL,n) - -/* - * This slow call was found to be to an unevaluated function; undo the - * ticks we did in TICK_SLOW_CALL. - */ -#define TICK_SLOW_CALL_UNEVALD(n) \ - TICK_BUMP(SLOW_CALL_UNEVALD_ctr); \ - TICK_BUMP_BY(SLOW_CALL_ctr,-1); \ - TICK_HISTO_BY(SLOW_CALL,n,-1); - -/* Updating a closure with a new CON */ -#define TICK_UPD_CON_IN_NEW(n) \ - TICK_BUMP(UPD_CON_IN_NEW_ctr); \ - TICK_HISTO(UPD_CON_IN_NEW,n) - -#define TICK_ALLOC_HEAP_NOCTR(bytes) \ - TICK_BUMP(ALLOC_RTS_ctr); \ - TICK_BUMP_BY(ALLOC_RTS_tot,bytes) - -/* ----------------------------------------------------------------------------- - Saving and restoring STG registers - - STG registers must be saved around a C call, just in case the STG - register is mapped to a caller-saves machine register. Normally we - don't need to worry about this the code generator has already - loaded any live STG registers into variables for us, but in - hand-written low-level Cmm code where we don't know which registers - are live, we might have to save them all. - -------------------------------------------------------------------------- */ - -#define SAVE_STGREGS \ - W_ r1, r2, r3, r4, r5, r6, r7, r8; \ - F_ f1, f2, f3, f4, f5, f6; \ - D_ d1, d2, d3, d4, d5, d6; \ - L_ l1; \ - \ - r1 = R1; \ - r2 = R2; \ - r3 = R3; \ - r4 = R4; \ - r5 = R5; \ - r6 = R6; \ - r7 = R7; \ - r8 = R8; \ - \ - f1 = F1; \ - f2 = F2; \ - f3 = F3; \ - f4 = F4; \ - f5 = F5; \ - f6 = F6; \ - \ - d1 = D1; \ - d2 = D2; \ - d3 = D3; \ - d4 = D4; \ - d5 = D5; \ - d6 = D6; \ - \ - l1 = L1; - - -#define RESTORE_STGREGS \ - R1 = r1; \ - R2 = r2; \ - R3 = r3; \ - R4 = r4; \ - R5 = r5; \ - R6 = r6; \ - R7 = r7; \ - R8 = r8; \ - \ - F1 = f1; \ - F2 = f2; \ - F3 = f3; \ - F4 = f4; \ - F5 = f5; \ - F6 = f6; \ - \ - D1 = d1; \ - D2 = d2; \ - D3 = d3; \ - D4 = d4; \ - D5 = d5; \ - D6 = d6; \ - \ - L1 = l1; - -/* ----------------------------------------------------------------------------- - Misc junk - -------------------------------------------------------------------------- */ - -#define NO_TREC stg_NO_TREC_closure -#define END_TSO_QUEUE stg_END_TSO_QUEUE_closure -#define STM_AWOKEN stg_STM_AWOKEN_closure - -#define recordMutableCap(p, gen) \ - W_ __bd; \ - W_ mut_list; \ - mut_list = Capability_mut_lists(MyCapability()) + WDS(gen); \ - __bd = W_[mut_list]; \ - if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \ - W_ __new_bd; \ - ("ptr" __new_bd) = foreign "C" allocBlock_lock(); \ - bdescr_link(__new_bd) = __bd; \ - __bd = __new_bd; \ - W_[mut_list] = __bd; \ - } \ - W_ free; \ - free = bdescr_free(__bd); \ - W_[free] = p; \ - bdescr_free(__bd) = free + WDS(1); - -#define recordMutable(p) \ - P_ __p; \ - W_ __bd; \ - W_ __gen; \ - __p = p; \ - __bd = Bdescr(__p); \ - __gen = TO_W_(bdescr_gen_no(__bd)); \ - if (__gen > 0) { recordMutableCap(__p, __gen); } - -/* ----------------------------------------------------------------------------- - Arrays - -------------------------------------------------------------------------- */ - -/* Complete function body for the clone family of (mutable) array ops. - Defined as a macro to avoid function call overhead or code - duplication. */ -#define cloneArray(info, src, offset, n) \ - W_ words, size; \ - gcptr dst, dst_p, src_p; \ - \ - again: MAYBE_GC(again); \ - \ - size = n + mutArrPtrsCardWords(n); \ - words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; \ - ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \ - TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); \ - \ - SET_HDR(dst, info, CCCS); \ - StgMutArrPtrs_ptrs(dst) = n; \ - StgMutArrPtrs_size(dst) = size; \ - \ - dst_p = dst + SIZEOF_StgMutArrPtrs; \ - src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset); \ - prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \ - \ - return (dst); - -#define copyArray(src, src_off, dst, dst_off, n) \ - W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \ - \ - if ((n) != 0) { \ - SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \ - \ - dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \ - dst_p = dst_elems_p + WDS(dst_off); \ - src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \ - bytes = WDS(n); \ - \ - prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \ - \ - dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \ - setCards(dst_cards_p, dst_off, n); \ - } \ - \ - return (); - -#define copyMutableArray(src, src_off, dst, dst_off, n) \ - W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \ - \ - if ((n) != 0) { \ - SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \ - \ - dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \ - dst_p = dst_elems_p + WDS(dst_off); \ - src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \ - bytes = WDS(n); \ - \ - if ((src) == (dst)) { \ - prim %memmove(dst_p, src_p, bytes, SIZEOF_W); \ - } else { \ - prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \ - } \ - \ - dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \ - setCards(dst_cards_p, dst_off, n); \ - } \ - \ - return (); - -/* - * Set the cards in the cards table pointed to by dst_cards_p for an - * update to n elements, starting at element dst_off. - */ -#define setCards(dst_cards_p, dst_off, n) \ - W_ __start_card, __end_card, __cards; \ - __start_card = mutArrPtrCardDown(dst_off); \ - __end_card = mutArrPtrCardDown((dst_off) + (n) - 1); \ - __cards = __end_card - __start_card + 1; \ - prim %memset((dst_cards_p) + __start_card, 1, __cards, 1); - -/* Complete function body for the clone family of small (mutable) - array ops. Defined as a macro to avoid function call overhead or - code duplication. */ -#define cloneSmallArray(info, src, offset, n) \ - W_ words, size; \ - gcptr dst, dst_p, src_p; \ - \ - again: MAYBE_GC(again); \ - \ - words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n; \ - ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \ - TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0); \ - \ - SET_HDR(dst, info, CCCS); \ - StgSmallMutArrPtrs_ptrs(dst) = n; \ - \ - dst_p = dst + SIZEOF_StgSmallMutArrPtrs; \ - src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset); \ - prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \ - \ - return (dst); diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -495,13 +495,13 @@ ,DoubleReg 1 #endif #if defined(REG_XMM1) - ,XmmReg 1 2 W64 Integer + ,XmmReg 1 #endif #if defined(REG_YMM1) - ,YmmReg 1 4 W64 Integer + ,YmmReg 1 #endif #if defined(REG_ZMM1) - ,ZmmReg 1 8 W64 Integer + ,ZmmReg 1 #endif #if defined(REG_F2) ,FloatReg 2 @@ -510,13 +510,13 @@ ,DoubleReg 2 #endif #if defined(REG_XMM2) - ,XmmReg 2 2 W64 Integer + ,XmmReg 2 #endif #if defined(REG_YMM2) - ,YmmReg 2 4 W64 Integer + ,YmmReg 2 #endif #if defined(REG_ZMM2) - ,ZmmReg 2 8 W64 Integer + ,ZmmReg 2 #endif #if defined(REG_F3) ,FloatReg 3 @@ -525,13 +525,13 @@ ,DoubleReg 3 #endif #if defined(REG_XMM3) - ,XmmReg 3 2 W64 Integer + ,XmmReg 3 #endif #if defined(REG_YMM3) - ,YmmReg 3 4 W64 Integer + ,YmmReg 3 #endif #if defined(REG_ZMM3) - ,ZmmReg 3 8 W64 Integer + ,ZmmReg 3 #endif #if defined(REG_F4) ,FloatReg 4 @@ -540,13 +540,13 @@ ,DoubleReg 4 #endif #if defined(REG_XMM4) - ,XmmReg 4 2 W64 Integer + ,XmmReg 4 #endif #if defined(REG_YMM4) - ,YmmReg 4 4 W64 Integer + ,YmmReg 4 #endif #if defined(REG_ZMM4) - ,ZmmReg 4 8 W64 Integer + ,ZmmReg 4 #endif #if defined(REG_F5) ,FloatReg 5 @@ -555,13 +555,13 @@ ,DoubleReg 5 #endif #if defined(REG_XMM5) - ,XmmReg 5 2 W64 Integer + ,XmmReg 5 #endif #if defined(REG_YMM5) - ,YmmReg 5 4 W64 Integer + ,YmmReg 5 #endif #if defined(REG_ZMM5) - ,ZmmReg 5 8 W64 Integer + ,ZmmReg 5 #endif #if defined(REG_F6) ,FloatReg 6 @@ -570,13 +570,13 @@ ,DoubleReg 6 #endif #if defined(REG_XMM6) - ,XmmReg 6 2 W64 Integer + ,XmmReg 6 #endif #if defined(REG_YMM6) - ,YmmReg 6 4 W64 Integer + ,YmmReg 6 #endif #if defined(REG_ZMM6) - ,ZmmReg 6 8 W64 Integer + ,ZmmReg 6 #endif #else /* MAX_REAL_XMM_REG == 0 */ #if defined(REG_F1) @@ -733,62 +733,62 @@ # endif # if MAX_REAL_XMM_REG != 0 # if defined(REG_XMM1) -globalRegMaybe (XmmReg 1 _ _ _) = Just (RealRegSingle REG_XMM1) +globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) # endif # if defined(REG_XMM2) -globalRegMaybe (XmmReg 2 _ _ _) = Just (RealRegSingle REG_XMM2) +globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) # endif # if defined(REG_XMM3) -globalRegMaybe (XmmReg 3 _ _ _) = Just (RealRegSingle REG_XMM3) +globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) # endif # if defined(REG_XMM4) -globalRegMaybe (XmmReg 4 _ _ _) = Just (RealRegSingle REG_XMM4) +globalRegMaybe (XmmReg 4) = Just (RealRegSingle REG_XMM4) # endif # if defined(REG_XMM5) -globalRegMaybe (XmmReg 5 _ _ _) = Just (RealRegSingle REG_XMM5) +globalRegMaybe (XmmReg 5) = Just (RealRegSingle REG_XMM5) # endif # if defined(REG_XMM6) -globalRegMaybe (XmmReg 6 _ _ _) = Just (RealRegSingle REG_XMM6) +globalRegMaybe (XmmReg 6) = Just (RealRegSingle REG_XMM6) # endif # endif # if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0 # if defined(REG_YMM1) -globalRegMaybe (YmmReg 1 _ _ _) = Just (RealRegSingle REG_YMM1) +globalRegMaybe (YmmReg 1) = Just (RealRegSingle REG_YMM1) # endif # if defined(REG_YMM2) -globalRegMaybe (YmmReg 2 _ _ _) = Just (RealRegSingle REG_YMM2) +globalRegMaybe (YmmReg 2) = Just (RealRegSingle REG_YMM2) # endif # if defined(REG_YMM3) -globalRegMaybe (YmmReg 3 _ _ _) = Just (RealRegSingle REG_YMM3) +globalRegMaybe (YmmReg 3) = Just (RealRegSingle REG_YMM3) # endif # if defined(REG_YMM4) -globalRegMaybe (YmmReg 4 _ _ _) = Just (RealRegSingle REG_YMM4) +globalRegMaybe (YmmReg 4) = Just (RealRegSingle REG_YMM4) # endif # if defined(REG_YMM5) -globalRegMaybe (YmmReg 5 _ _ _) = Just (RealRegSingle REG_YMM5) +globalRegMaybe (YmmReg 5) = Just (RealRegSingle REG_YMM5) # endif # if defined(REG_YMM6) -globalRegMaybe (YmmReg 6 _ _ _) = Just (RealRegSingle REG_YMM6) +globalRegMaybe (YmmReg 6) = Just (RealRegSingle REG_YMM6) # endif # endif # if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0 # if defined(REG_ZMM1) -globalRegMaybe (ZmmReg 1 _ _ _) = Just (RealRegSingle REG_ZMM1) +globalRegMaybe (ZmmReg 1) = Just (RealRegSingle REG_ZMM1) # endif # if defined(REG_ZMM2) -globalRegMaybe (ZmmReg 2 _ _ _) = Just (RealRegSingle REG_ZMM2) +globalRegMaybe (ZmmReg 2) = Just (RealRegSingle REG_ZMM2) # endif # if defined(REG_ZMM3) -globalRegMaybe (ZmmReg 3 _ _ _) = Just (RealRegSingle REG_ZMM3) +globalRegMaybe (ZmmReg 3) = Just (RealRegSingle REG_ZMM3) # endif # if defined(REG_ZMM4) -globalRegMaybe (ZmmReg 4 _ _ _) = Just (RealRegSingle REG_ZMM4) +globalRegMaybe (ZmmReg 4) = Just (RealRegSingle REG_ZMM4) # endif # if defined(REG_ZMM5) -globalRegMaybe (ZmmReg 5 _ _ _) = Just (RealRegSingle REG_ZMM5) +globalRegMaybe (ZmmReg 5) = Just (RealRegSingle REG_ZMM5) # endif # if defined(REG_ZMM6) -globalRegMaybe (ZmmReg 6 _ _ _) = Just (RealRegSingle REG_ZMM6) +globalRegMaybe (ZmmReg 6) = Just (RealRegSingle REG_ZMM6) # endif # endif # if defined(REG_Sp) diff --git a/includes/HsFFI.h b/includes/HsFFI.h deleted file mode 100644 --- a/includes/HsFFI.h +++ /dev/null @@ -1,141 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 2000 - * - * A mapping for Haskell types to C types, including the corresponding bounds. - * Intended to be used in conjuction with the FFI. - * - * WARNING: Keep this file and StgTypes.h in synch! - * - * ---------------------------------------------------------------------------*/ - -#pragma once - -#if defined(__cplusplus) -extern "C" { -#endif - -/* get types from GHC's runtime system */ -#include "ghcconfig.h" -#include "stg/Types.h" - -/* get limits for floating point types */ -#include - -typedef StgChar HsChar; -typedef StgInt HsInt; -typedef StgInt8 HsInt8; -typedef StgInt16 HsInt16; -typedef StgInt32 HsInt32; -typedef StgInt64 HsInt64; -typedef StgWord HsWord; -typedef StgWord8 HsWord8; -typedef StgWord16 HsWord16; -typedef StgWord32 HsWord32; -typedef StgWord64 HsWord64; -typedef StgFloat HsFloat; -typedef StgDouble HsDouble; -typedef StgInt HsBool; -typedef void* HsPtr; /* this should better match StgAddr */ -typedef void (*HsFunPtr)(void); /* this should better match StgAddr */ -typedef void* HsStablePtr; - -/* this should correspond to the type of StgChar in StgTypes.h */ -#define HS_CHAR_MIN 0 -#define HS_CHAR_MAX 0x10FFFF - -/* is it true or not? */ -#define HS_BOOL_FALSE 0 -#define HS_BOOL_TRUE 1 - -#define HS_BOOL_MIN HS_BOOL_FALSE -#define HS_BOOL_MAX HS_BOOL_TRUE - - -#define HS_INT_MIN STG_INT_MIN -#define HS_INT_MAX STG_INT_MAX -#define HS_WORD_MAX STG_WORD_MAX - -#define HS_INT8_MIN STG_INT8_MIN -#define HS_INT8_MAX STG_INT8_MAX -#define HS_INT16_MIN STG_INT16_MIN -#define HS_INT16_MAX STG_INT16_MAX -#define HS_INT32_MIN STG_INT32_MIN -#define HS_INT32_MAX STG_INT32_MAX -#define HS_INT64_MIN STG_INT64_MIN -#define HS_INT64_MAX STG_INT64_MAX -#define HS_WORD8_MAX STG_WORD8_MAX -#define HS_WORD16_MAX STG_WORD16_MAX -#define HS_WORD32_MAX STG_WORD32_MAX -#define HS_WORD64_MAX STG_WORD64_MAX - -#define HS_FLOAT_RADIX FLT_RADIX -#define HS_FLOAT_ROUNDS FLT_ROUNDS -#define HS_FLOAT_EPSILON FLT_EPSILON -#define HS_FLOAT_DIG FLT_DIG -#define HS_FLOAT_MANT_DIG FLT_MANT_DIG -#define HS_FLOAT_MIN FLT_MIN -#define HS_FLOAT_MIN_EXP FLT_MIN_EXP -#define HS_FLOAT_MIN_10_EXP FLT_MIN_10_EXP -#define HS_FLOAT_MAX FLT_MAX -#define HS_FLOAT_MAX_EXP FLT_MAX_EXP -#define HS_FLOAT_MAX_10_EXP FLT_MAX_10_EXP - -#define HS_DOUBLE_RADIX DBL_RADIX -#define HS_DOUBLE_ROUNDS DBL_ROUNDS -#define HS_DOUBLE_EPSILON DBL_EPSILON -#define HS_DOUBLE_DIG DBL_DIG -#define HS_DOUBLE_MANT_DIG DBL_MANT_DIG -#define HS_DOUBLE_MIN DBL_MIN -#define HS_DOUBLE_MIN_EXP DBL_MIN_EXP -#define HS_DOUBLE_MIN_10_EXP DBL_MIN_10_EXP -#define HS_DOUBLE_MAX DBL_MAX -#define HS_DOUBLE_MAX_EXP DBL_MAX_EXP -#define HS_DOUBLE_MAX_10_EXP DBL_MAX_10_EXP - -extern void hs_init (int *argc, char **argv[]); -extern void hs_exit (void); -extern void hs_exit_nowait(void); -extern void hs_set_argv (int argc, char *argv[]); -extern void hs_thread_done (void); - -extern void hs_perform_gc (void); - -// Lock the stable pointer table. The table must be unlocked -// again before calling any Haskell functions, even if those -// functions do not manipulate stable pointers. The Haskell -// garbage collector will not be able to run until this lock -// is released! It is also forbidden to call hs_free_fun_ptr -// or any stable pointer-related FFI functions other than -// hs_free_stable_ptr_unsafe while the table is locked. -extern void hs_lock_stable_ptr_table (void); - -// A deprecated synonym. -extern void hs_lock_stable_tables (void); - -// Unlock the stable pointer table. -extern void hs_unlock_stable_ptr_table (void); - -// A deprecated synonym. -extern void hs_unlock_stable_tables (void); - -// Free a stable pointer assuming that the stable pointer -// table is already locked. -extern void hs_free_stable_ptr_unsafe (HsStablePtr sp); - -extern void hs_free_stable_ptr (HsStablePtr sp); -extern void hs_free_fun_ptr (HsFunPtr fp); - -extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2); -extern int hs_spt_keys(StgPtr keys[], int szKeys); -extern int hs_spt_key_count (void); - -extern void hs_try_putmvar (int capability, HsStablePtr sp); - -/* -------------------------------------------------------------------------- */ - - - -#if defined(__cplusplus) -} -#endif diff --git a/includes/Rts.h b/includes/Rts.h deleted file mode 100644 --- a/includes/Rts.h +++ /dev/null @@ -1,325 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1998-2009 - * - * RTS external APIs. This file declares everything that the GHC RTS - * exposes externally. - * - * To understand the structure of the RTS headers, see the wiki: - * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes - * - * ---------------------------------------------------------------------------*/ - -#pragma once - -#if defined(__cplusplus) -extern "C" { -#endif - -/* We include windows.h very early, as on Win64 the CONTEXT type has - fields "R8", "R9" and "R10", which goes bad if we've already - #define'd those names for our own purposes (in stg/Regs.h) */ -#if defined(HAVE_WINDOWS_H) -#include -#endif - -#if !defined(IN_STG_CODE) -#define IN_STG_CODE 0 -#endif -#include "Stg.h" - -#include "HsFFI.h" -#include "RtsAPI.h" - -// Turn off inlining when debugging - it obfuscates things -#if defined(DEBUG) -# undef STATIC_INLINE -# define STATIC_INLINE static -#endif - -#include "rts/Types.h" -#include "rts/Time.h" - -#if __GNUC__ >= 3 -#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n))) -#else -#define ATTRIBUTE_ALIGNED(n) /*nothing*/ -#endif - -// Symbols that are extern, but private to the RTS, are declared -// with visibility "hidden" to hide them outside the RTS shared -// library. -#if defined(HAS_VISIBILITY_HIDDEN) -#define RTS_PRIVATE GNUC3_ATTRIBUTE(visibility("hidden")) -#else -#define RTS_PRIVATE /* disabled: RTS_PRIVATE */ -#endif - -#if __GNUC__ >= 4 -#define RTS_UNLIKELY(p) __builtin_expect((p),0) -#else -#define RTS_UNLIKELY(p) (p) -#endif - -#if __GNUC__ >= 4 -#define RTS_LIKELY(p) __builtin_expect(!!(p), 1) -#else -#define RTS_LIKELY(p) (p) -#endif - -/* __builtin_unreachable is supported since GNU C 4.5 */ -#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) -#define RTS_UNREACHABLE __builtin_unreachable() -#else -#define RTS_UNREACHABLE abort() -#endif - -/* Fix for mingw stat problem (done here so it's early enough) */ -#if defined(mingw32_HOST_OS) -#define __MSVCRT__ 1 -#endif - -/* Needed to get the macro version of errno on some OSs, and also to - get prototypes for the _r versions of C library functions. */ -#if !defined(_REENTRANT) -#define _REENTRANT 1 -#endif - -/* - * We often want to know the size of something in units of an - * StgWord... (rounded up, of course!) - */ -#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_)) - -#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t)) - -/* ----------------------------------------------------------------------------- - Assertions and Debuggery - - CHECK(p) evaluates p and terminates with an error if p is false - ASSERT(p) like CHECK(p) if DEBUG is on, otherwise a no-op - -------------------------------------------------------------------------- */ - -void _assertFail(const char *filename, unsigned int linenum) - GNUC3_ATTRIBUTE(__noreturn__); - -#define CHECK(predicate) \ - if (predicate) \ - /*null*/; \ - else \ - _assertFail(__FILE__, __LINE__) - -#define CHECKM(predicate, msg, ...) \ - if (predicate) \ - /*null*/; \ - else \ - barf(msg, ##__VA_ARGS__) - -#if !defined(DEBUG) -#define ASSERT(predicate) /* nothing */ -#define ASSERTM(predicate,msg,...) /* nothing */ -#else -#define ASSERT(predicate) CHECK(predicate) -#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__) -#endif /* DEBUG */ - -/* - * Use this on the RHS of macros which expand to nothing - * to make sure that the macro can be used in a context which - * demands a non-empty statement. - */ - -#define doNothing() do { } while (0) - -#if defined(DEBUG) -#define USED_IF_DEBUG -#define USED_IF_NOT_DEBUG STG_UNUSED -#else -#define USED_IF_DEBUG STG_UNUSED -#define USED_IF_NOT_DEBUG -#endif - -#if defined(THREADED_RTS) -#define USED_IF_THREADS -#define USED_IF_NOT_THREADS STG_UNUSED -#else -#define USED_IF_THREADS STG_UNUSED -#define USED_IF_NOT_THREADS -#endif - -#if defined(PROFILING) -#define USED_IF_PROFILING -#define USED_IF_NOT_PROFILING STG_UNUSED -#else -#define USED_IF_PROFILING STG_UNUSED -#define USED_IF_NOT_PROFILING -#endif - -#define FMT_SizeT "zu" -#define FMT_HexSizeT "zx" - -/* ----------------------------------------------------------------------------- - Include everything STG-ish - -------------------------------------------------------------------------- */ - -/* System headers: stdlib.h is needed so that we can use NULL. It must - * come after MachRegs.h, because stdlib.h might define some inline - * functions which may only be defined after register variables have - * been declared. - */ -#include - -#include "rts/Config.h" - -/* Global constraints */ -#include "rts/Constants.h" - -/* Profiling information */ -#include "rts/prof/CCS.h" -#include "rts/prof/LDV.h" - -/* Parallel information */ -#include "rts/OSThreads.h" -#include "rts/SpinLock.h" - -#include "rts/Messages.h" -#include "rts/Threads.h" - -/* Storage format definitions */ -#include "rts/storage/FunTypes.h" -#include "rts/storage/InfoTables.h" -#include "rts/storage/Closures.h" -#include "rts/storage/Heap.h" -#include "rts/storage/ClosureTypes.h" -#include "rts/storage/TSO.h" -#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */ -#include "rts/storage/Block.h" -#include "rts/storage/ClosureMacros.h" -#include "rts/storage/MBlock.h" -#include "rts/storage/GC.h" - -/* Other RTS external APIs */ -#include "rts/Parallel.h" -#include "rts/Signals.h" -#include "rts/BlockSignals.h" -#include "rts/Hpc.h" -#include "rts/Flags.h" -#include "rts/Adjustor.h" -#include "rts/FileLock.h" -#include "rts/GetTime.h" -#include "rts/Globals.h" -#include "rts/IOManager.h" -#include "rts/Linker.h" -#include "rts/Ticky.h" -#include "rts/Timer.h" -#include "rts/StablePtr.h" -#include "rts/StableName.h" -#include "rts/TTY.h" -#include "rts/Utils.h" -#include "rts/PrimFloat.h" -#include "rts/Main.h" -#include "rts/Profiling.h" -#include "rts/StaticPtrTable.h" -#include "rts/Libdw.h" -#include "rts/LibdwPool.h" - -/* Misc stuff without a home */ -DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */ -DLL_IMPORT_RTS extern int prog_argc; -DLL_IMPORT_RTS extern char *prog_name; - -void reportStackOverflow(StgTSO* tso); -void reportHeapOverflow(void); - -void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__); - -#if !defined(mingw32_HOST_OS) -int stg_sig_install (int, int, void *); -#endif - -/* ----------------------------------------------------------------------------- - Ways - -------------------------------------------------------------------------- */ - -// Returns non-zero if the RTS is a profiling version -int rts_isProfiled(void); - -// Returns non-zero if the RTS is a dynamically-linked version -int rts_isDynamic(void); - -/* ----------------------------------------------------------------------------- - RTS Exit codes - -------------------------------------------------------------------------- */ - -/* 255 is allegedly used by dynamic linkers to report linking failure */ -#define EXIT_INTERNAL_ERROR 254 -#define EXIT_DEADLOCK 253 -#define EXIT_INTERRUPTED 252 -#define EXIT_HEAPOVERFLOW 251 -#define EXIT_KILLED 250 - -/* ----------------------------------------------------------------------------- - Miscellaneous garbage - -------------------------------------------------------------------------- */ - -#if defined(DEBUG) -#define TICK_VAR(arity) \ - extern StgInt SLOW_CALLS_##arity; \ - extern StgInt RIGHT_ARITY_##arity; \ - extern StgInt TAGGED_PTR_##arity; - -extern StgInt TOTAL_CALLS; - -TICK_VAR(1) -TICK_VAR(2) -#endif - -/* ----------------------------------------------------------------------------- - Assertions and Debuggery - -------------------------------------------------------------------------- */ - -#define IF_RTSFLAGS(c,s) if (RtsFlags.c) { s; } doNothing() - -#if defined(DEBUG) -#if IN_STG_CODE -#define IF_DEBUG(c,s) if (RtsFlags[0].DebugFlags.c) { s; } doNothing() -#else -#define IF_DEBUG(c,s) if (RtsFlags.DebugFlags.c) { s; } doNothing() -#endif -#else -#define IF_DEBUG(c,s) doNothing() -#endif - -#if defined(DEBUG) -#define DEBUG_ONLY(s) s -#else -#define DEBUG_ONLY(s) doNothing() -#endif - -#if defined(DEBUG) -#define DEBUG_IS_ON 1 -#else -#define DEBUG_IS_ON 0 -#endif - -/* ----------------------------------------------------------------------------- - Useful macros and inline functions - -------------------------------------------------------------------------- */ - -#if defined(__GNUC__) -#define SUPPORTS_TYPEOF -#endif - -#if defined(SUPPORTS_TYPEOF) -#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; }) -#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; }) -#else -#define stg_min(a,b) ((a) <= (b) ? (a) : (b)) -#define stg_max(a,b) ((a) <= (b) ? (b) : (a)) -#endif - -/* -------------------------------------------------------------------------- */ - -#if defined(__cplusplus) -} -#endif diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h deleted file mode 100644 --- a/includes/RtsAPI.h +++ /dev/null @@ -1,487 +0,0 @@ -/* ---------------------------------------------------------------------------- - * - * (c) The GHC Team, 1998-2004 - * - * API for invoking Haskell functions via the RTS - * - * To understand the structure of the RTS headers, see the wiki: - * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes - * - * --------------------------------------------------------------------------*/ - -#pragma once - -#if defined(__cplusplus) -extern "C" { -#endif - -#include "HsFFI.h" -#include "rts/Time.h" -#include "rts/EventLogWriter.h" - -/* - * Running the scheduler - */ -typedef enum { - NoStatus, /* not finished yet */ - Success, /* completed successfully */ - Killed, /* uncaught exception */ - Interrupted, /* stopped in response to a call to interruptStgRts */ - HeapExhausted /* out of memory */ -} SchedulerStatus; - -typedef struct StgClosure_ *HaskellObj; - -/* - * An abstract type representing the token returned by rts_lock() and - * used when allocating objects and threads in the RTS. - */ -typedef struct Capability_ Capability; - -/* - * The public view of a Capability: we can be sure it starts with - * these two components (but it may have more private fields). - */ -typedef struct CapabilityPublic_ { - StgFunTable f; - StgRegTable r; -} CapabilityPublic; - -/* ---------------------------------------------------------------------------- - RTS configuration settings, for passing to hs_init_ghc() - ------------------------------------------------------------------------- */ - -typedef enum { - RtsOptsNone, // +RTS causes an error - RtsOptsIgnore, // Ignore command line arguments - RtsOptsIgnoreAll, // Ignore command line and Environment arguments - RtsOptsSafeOnly, // safe RTS options allowed; others cause an error - RtsOptsAll // all RTS options allowed - } RtsOptsEnabledEnum; - -struct GCDetails_; - -// The RtsConfig struct is passed (by value) to hs_init_ghc(). The -// reason for using a struct is extensibility: we can add more -// fields to this later without breaking existing client code. -typedef struct { - - // Whether to interpret +RTS options on the command line - RtsOptsEnabledEnum rts_opts_enabled; - - // Whether to give RTS flag suggestions - HsBool rts_opts_suggestions; - - // additional RTS options - const char *rts_opts; - - // True if GHC was not passed -no-hs-main - HsBool rts_hs_main; - - // Whether to retain CAFs (default: false) - HsBool keep_cafs; - - // Writer a for eventlog. - const EventLogWriter *eventlog_writer; - - // Called before processing command-line flags, so that default - // settings for RtsFlags can be provided. - void (* defaultsHook) (void); - - // Called just before exiting - void (* onExitHook) (void); - - // Called on a stack overflow, before exiting - void (* stackOverflowHook) (W_ stack_size); - - // Called on heap overflow, before exiting - void (* outOfHeapHook) (W_ request_size, W_ heap_size); - - // Called when malloc() fails, before exiting - void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg); - - // Called for every GC - void (* gcDoneHook) (const struct GCDetails_ *stats); - - // Called when GC sync takes too long (+RTS --long-gc-sync=