diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-04-19 11:06:20 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-04-19 11:06:20 +0100 |
| commit | fdf8656855d26105ff36bdd24d41827b05037b91 (patch) | |
| tree | fbbaeb08132051cde17ec7c3020cb835b04b947e /compiler | |
| parent | a52ff7619e8b7d74a9d933d922eeea49f580bca8 (diff) | |
| download | haskell-fdf8656855d26105ff36bdd24d41827b05037b91.tar.gz | |
This BIG PATCH contains most of the work for the New Coercion Representation
See the paper "Practical aspects of evidence based compilation in System FC"
* Coercion becomes a data type, distinct from Type
* Coercions become value-level things, rather than type-level things,
(although the value is zero bits wide, like the State token)
A consequence is that a coerion abstraction increases the arity by 1
(just like a dictionary abstraction)
* There is a new constructor in CoreExpr, namely Coercion, to inject
coercions into terms
Diffstat (limited to 'compiler')
130 files changed, 4823 insertions, 4021 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 5a62326718..fae899d4d1 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -18,7 +18,7 @@ module DataCon ( dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConOrigTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, - dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, + dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, @@ -31,7 +31,7 @@ module DataCon ( -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, - isVanillaDataCon, classDataCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, -- * Splitting product types splitProductType_maybe, splitProductType, deepSplitProductType, @@ -41,6 +41,7 @@ module DataCon ( #include "HsVersions.h" import Type +import Unify import Coercion import TyCon import Class @@ -57,7 +58,6 @@ import Module import qualified Data.Data as Data import Data.Char import Data.Word -import Data.List ( partition ) \end{code} @@ -256,8 +256,7 @@ data DataCon -- dcUnivTyVars = [a] -- dcExTyVars = [x,y] -- dcEqSpec = [a~(x,y)] - -- dcEqTheta = [x~y] - -- dcDictTheta = [Ord x] + -- dcOtherTheta = [x~y, Ord x] -- dcOrigArgTys = [a,List b] -- dcRepTyCon = T @@ -265,7 +264,7 @@ data DataCon -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = [] + -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. @@ -300,8 +299,8 @@ data DataCon -- In GADT form, this is *exactly* what the programmer writes, even if -- the context constrains only universally quantified variables -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b - dcEqTheta :: ThetaType, -- The *equational* constraints - dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- *other than* those in the dcEqSpec dcStupidTheta :: ThetaType, -- The context of the data type declaration -- data Eq a => T a = ... @@ -338,9 +337,9 @@ data DataCon -- length = 0 (if not a record) or dataConSourceArity. -- Constructor representation - dcRepArgTys :: [Type], -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* existential dictionaries + dcRepArgTys :: [Type], -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all existential evidence args dcRepStrictness :: [StrictnessMark], -- One for each *representation* *value* argument @@ -519,8 +518,8 @@ mkDataCon name declared_infix dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, + dcOtherTheta = theta, dcStupidTheta = stupid_theta, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, dcRepArgTys = rep_arg_tys, @@ -536,10 +535,9 @@ mkDataCon name declared_infix -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the -- dictionary arguments right here. - (eq_theta,dict_theta) = partition isEqPred theta - dict_tys = mkPredTys dict_theta - real_arg_tys = dict_tys ++ orig_arg_tys - real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts + full_theta = eqSpecPreds eq_spec ++ theta + real_arg_tys = mkPredTys full_theta ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts -- Representation arguments and demands -- To do: eliminate duplication with MkId @@ -547,11 +545,6 @@ mkDataCon name declared_infix tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ - mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $ - mkFunTys (mkPredTys eq_theta) $ - -- NB: the dict args are already in rep_arg_tys - -- because they might be flattened.. - -- but the equality predicates are not mkFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) @@ -611,13 +604,10 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) dataConEqSpec :: DataCon -> [(TyVar,Type)] dataConEqSpec = dcEqSpec --- | The equational constraints on the data constructor type -dataConEqTheta :: DataCon -> ThetaType -dataConEqTheta = dcEqTheta - --- | The type class and implicit parameter contsraints on the data constructor type -dataConDictTheta :: DataCon -> ThetaType -dataConDictTheta = dcDictTheta +-- | The *full* constraints on the constructor type +dataConTheta :: DataCon -> ThetaType +dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds eq_spec ++ theta -- | Get the Id of the 'DataCon' worker: a function that is the "actual" -- constructor and has no top level binding in the program. The type may @@ -666,10 +656,10 @@ dataConFieldType con label dataConStrictMarks :: DataCon -> [HsBang] dataConStrictMarks = dcStrictMarks --- | Strictness of /existential/ arguments only +-- | Strictness of evidence arguments to the wrapper function dataConExStricts :: DataCon -> [HsBang] -- Usually empty, so we don't bother to cache this -dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc +dataConExStricts dc = map mk_dict_strict_mark $ (dcOtherTheta dc) -- | Source-level arity of the data constructor dataConSourceArity :: DataCon -> Arity @@ -705,10 +695,10 @@ dataConRepStrictness dc = dcRepStrictness dc -- -- 4) The /original/ result type of the 'DataCon' dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) -dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, +dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) -- | The \"full signature\" of the 'DataCon' returns, in order: -- @@ -725,11 +715,11 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_ -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc @@ -754,11 +744,10 @@ dataConUserType :: DataCon -> Type -- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys (mkPredTys eq_theta) $ - mkFunTys (mkPredTys dict_theta) $ + mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ res_ty @@ -841,6 +830,24 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of [] -> panic "classDataCon" \end{code} +\begin{code} +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the type constructor for the data con +-- +dataConCannotMatch tys con + | null eq_spec = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise + = typesCantMatch (map (substTyVar subst . fst) eq_spec) + (map snd eq_spec) + where + dc_tvs = dataConUnivTyVars con + eq_spec = dataConEqSpec con + subst = zipTopTvSubst dc_tvs tys +\end{code} + %************************************************************************ %* * \subsection{Splitting products} diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index fd65fe4009..5ac261255c 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -23,7 +23,7 @@ -- * 'Var.Var': see "Var#name_types" module Id ( -- * The main types - Id, DictId, + Var, Id, isId, -- ** Simple construction mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, @@ -34,8 +34,7 @@ module Id ( -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, - isId, idPrimRep, - recordSelectorFieldLabel, + idPrimRep, recordSelectorFieldLabel, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, @@ -46,7 +45,8 @@ module Id ( -- ** Predicates on Ids - isImplicitId, isDeadBinder, isDictId, isStrictId, + isImplicitId, isDeadBinder, + isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, isClassOpId_maybe, isDFunId, dfunNSilent, @@ -57,6 +57,9 @@ module Id ( isTickBoxOp, isTickBoxOp_maybe, hasNoBinding, + -- ** Evidence variables + DictId, isDictId, isEvVar, evVarPred, + -- ** Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, idInlineActivation, setInlineActivation, idRuleMatchInfo, @@ -95,8 +98,8 @@ import IdInfo import BasicTypes -- Imported and re-exported -import Var( Var, Id, DictId, - idInfo, idDetails, globaliseId, +import Var( Var, Id, DictId, EvVar, + idInfo, idDetails, globaliseId, varType, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var @@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -isDictId :: Id -> Bool -isDictId id = isDictTy (idType id) - hasNoBinding :: Id -> Bool -- ^ Returns @True@ of an 'Id' which may not have a -- binding, even though it is defined in this module. @@ -448,6 +447,26 @@ isTickBoxOp_maybe id = %************************************************************************ %* * + Evidence variables +%* * +%************************************************************************ + +\begin{code} +isEvVar :: Var -> Bool +isEvVar var = isPredTy (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +evVarPred :: EvVar -> PredType +evVarPred var + = case splitPredTy_maybe (varType var) of + Just pred -> pred + Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var)) +\end{code} + +%************************************************************************ +%* * \subsection{IdInfo stuff} %* * %************************************************************************ diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index ec1f122176..c106f5397c 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -10,7 +10,7 @@ Haskell. [WDP 94/11]) \begin{code} module IdInfo ( -- * The IdDetails type - IdDetails(..), pprIdDetails, + IdDetails(..), pprIdDetails, coVarDetails, -- * The IdInfo type IdInfo, -- Abstract @@ -141,6 +141,9 @@ data IdDetails -- implemented with a newtype, so it might be bad -- to be strict on this dictionary +coVarDetails :: IdDetails +coVarDetails = VanillaId + instance Outputable IdDetails where ppr = pprIdDetails diff --git a/compiler/basicTypes/IdInfo.lhs-boot b/compiler/basicTypes/IdInfo.lhs-boot index 4195156f27..257e1c6e5e 100644 --- a/compiler/basicTypes/IdInfo.lhs-boot +++ b/compiler/basicTypes/IdInfo.lhs-boot @@ -4,5 +4,7 @@ import Outputable data IdInfo data IdDetails +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails pprIdDetails :: IdDetails -> SDoc \end{code}
\ No newline at end of file diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 5aebd37259..328c51b872 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -25,13 +25,18 @@ module MkId ( -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceName, unsafeCoerceId, realWorldPrimId, - voidArgId, nullAddrId, seqId, lazyId, lazyIdKey + voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, + + -- Re-export error Ids + module PrelRules ) where #include "HsVersions.h" import Rules import TysPrim +import TysWiredIn ( unitTy ) import PrelRules import Type import Coercion @@ -48,7 +53,7 @@ import PrimOp import ForeignCall import DataCon import Id -import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar ) +import Var ( mkExportedLocalVar ) import IdInfo import Demand import CoreSyn @@ -56,6 +61,7 @@ import Unique import PrelNames import BasicTypes hiding ( SuccessFlag(..) ) import Util +import Pair import Outputable import FastString import ListSetOps @@ -224,7 +230,7 @@ mkDataConIds wrap_name wkr_name data_con = DCIds Nothing wrk_id where (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con + theta, orig_arg_tys, res_ty) = dataConFullSig data_con tycon = dataConTyCon data_con -- The representation TyCon (not family) ----------- Worker (algebraic data types only) -------------- @@ -287,12 +293,10 @@ mkDataConIds wrap_name wkr_name data_con -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs - eq_tys = mkPredTys eq_theta - dict_tys = mkPredTys dict_theta - wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $ - mkFunTys orig_arg_tys $ res_ty - -- NB: watch out here if you allow user-written equality - -- constraints in data constructor signatures + ev_tys = mkPredTys theta + wrap_ty = mkForAllTys wrap_tvs $ + mkFunTys ev_tys $ + mkFunTys orig_arg_tys $ res_ty ----------- Wrappers for algebraic data types -------------- alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info @@ -318,32 +322,23 @@ mkDataConIds wrap_name wkr_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs + wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs wrap_rhs = mkLams wrap_tvs $ - mkLams eq_args $ - mkLams dict_args $ mkLams id_args $ + mkLams ev_args $ + mkLams id_args $ foldr mk_case con_app - (zip (dict_args ++ id_args) all_strict_marks) + (zip (ev_args ++ id_args) all_strict_marks) i3 [] con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $ Var wrk_id `mkTyApps` res_ty_args `mkVarApps` ex_tvs - -- Equality evidence: - `mkTyApps` map snd eq_spec - `mkVarApps` eq_args + `mkCoApps` map (mkReflCo . snd) eq_spec `mkVarApps` reverse rep_ids - (dict_args,i2) = mkLocals 1 dict_tys - (id_args,i3) = mkLocals i2 orig_arg_tys - wrap_arity = i3-1 - (eq_args,_) = mkCoVarLocals i3 eq_tys - - mkCoVarLocals i [] = ([],i) - mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs - y = mkCoVar (mkSysTvName (mkBuiltinUnique i) - (fsLit "dc_co")) x - in (y:ys,j) + (ev_args,i2) = mkLocals 1 ev_tys + (id_args,i3) = mkLocals i2 orig_arg_tys + wrap_arity = i3-1 mk_case :: (Id, HsBang) -- Arg, strictness @@ -458,7 +453,7 @@ mkDictSelId no_unf name clas occNameFS (getOccName name) , ru_fn = name , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args n_eq_args } + , ru_try = dictSelRule val_index n_ty_args } -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting @@ -474,8 +469,6 @@ mkDictSelId no_unf name clas [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - eq_theta = dataConEqTheta data_con - n_eq_args = length eq_theta -- 'index' is a 0-index into the *value* arguments of the dictionary val_index = assoc "MkId.mkDictSelId" sel_index_prs name @@ -485,25 +478,23 @@ mkDictSelId no_unf name clas pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 $ mkPredTy pred arg_ids = mkTemplateLocalsNum 2 arg_tys - eq_ids = map mkWildEvBinder eq_theta rhs = mkLams tyvars (Lam dict_id rhs_body) rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] + [(DataAlt data_con, arg_ids, Var the_arg_id)] -dictSelRule :: Int -> Arity -> Arity +dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -dictSelRule val_index n_ty_args n_eq_args id_unf args +dictSelRule val_index n_ty_args id_unf args | (dict_arg : _) <- drop n_ty_args args , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - , let val_args = drop n_eq_args con_args - = Just (val_args !! val_index) + = Just (con_args !! val_index) | otherwise = Nothing \end{code} @@ -628,7 +619,7 @@ mkReboxingAlt us con args rhs -- Type variable case go (arg:args) stricts us - | isTyCoVar arg + | isTyVar arg = let (binds, args') = go args stricts us in (binds, arg:args') @@ -674,13 +665,11 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- coercion constructor of the newtype or applied by itself). wrapNewTypeBody tycon args result_expr - = wrapFamInstBody tycon args inner + = ASSERT( isNewTyCon tycon ) + wrapFamInstBody tycon args $ + mkCoerce (mkSymCo co) result_expr where - inner - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr - | otherwise - = result_expr + co = mkAxInstCo (newTyConCo tycon) args -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as @@ -689,10 +678,8 @@ wrapNewTypeBody tycon args result_expr unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkTyConApp co_con args) result_expr - | otherwise - = result_expr + = ASSERT( isNewTyCon tycon ) + mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr -- If the type constructor is a representation type of a data instance, wrap -- the expression into a cast adjusting the expression type, which is an @@ -702,14 +689,14 @@ unwrapNewTypeBody tycon args result_expr wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body + = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body | otherwise = body unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkTyConApp co_con args) scrut + = mkCoerce (mkAxInstCo co_con args) scrut | otherwise = scrut \end{code} @@ -858,7 +845,7 @@ mkDictFunTy tvs theta clas tys (classSCTheta clas) -- See Note [Silent Superclass Arguments] discard pred = isEmptyVarSet (tyVarsOfPred pred) - || any (`tcEqPred` pred) theta + || any (`eqPred` pred) theta -- See the DFun Superclass Invariant in TcInstDcls \end{code} @@ -885,12 +872,13 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} -lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name -unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId +lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name +unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId \end{code} \begin{code} @@ -908,7 +896,7 @@ unsafeCoerceId (mkFunTy argAlphaTy openBetaTy) [x] = mkTemplateLocals [argAlphaTy] rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy) + Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -944,7 +932,7 @@ seqId = pcMiscPrelId seqName ty info match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- See Note [Built-in RULES for seq] match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] - = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty, + = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, scrut, expr]) match_seq_of_cast _ _ = Nothing @@ -1054,6 +1042,12 @@ realWorldPrimId -- :: State# RealWorld voidArgId :: Id voidArgId -- :: State# RealWorld = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- Used to replace Coercion terms when we go to STG + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPredPrimTyCon [unitTy, unitTy]) + noCafIdInfo \end{code} diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index ec83494bb2..3376d0e501 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -32,7 +32,7 @@ module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId, + Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -41,34 +41,25 @@ module Var ( setVarName, setVarUnique, setVarType, -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, idInfo, idDetails, lazySetIdInfo, setIdDetails, globaliseId, setIdExported, setIdNotExported, -- ** Predicates - isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar, + isId, isTyVar, isTcTyVar, isLocalVar, isLocalId, isGlobalId, isExportedId, mustHaveLocalBinding, -- ** Constructing 'TyVar's - mkTyVar, mkTcTyVar, mkWildCoVar, + mkTyVar, mkTcTyVar, -- ** Taking 'TyVar's apart tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, - - -- ** Constructing 'CoVar's - mkCoVar, - - -- ** Taking 'CoVar's apart - coVarName, - - -- ** Modifying 'CoVar's - setCoVarUnique, setCoVarName + setTyVarName, setTyVarUnique, setTyVarKind ) where @@ -77,8 +68,7 @@ module Var ( import {-# SOURCE #-} TypeRep( Type, Kind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails ) -import {-# SOURCE #-} TypeRep( isCoercionKind ) +import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails ) import Name hiding (varName) import Unique @@ -100,7 +90,7 @@ import Data.Data -- large number of SOURCE imports of Id.hs :-( \begin{code} -type EvVar = Var -- An evidence variable: dictionary or equality constraint +type EvVar = Var -- An evidence variable: dictionary or equality constraint -- Could be an DictId or a CoVar type Id = Var -- A term-level identifier @@ -110,9 +100,10 @@ type DictId = EvId -- A dictionary variable type IpId = EvId -- A term-level implicit parameter type TyVar = Var -type CoVar = TyVar -- A coercion variable is simply a type +type CoVar = Id -- A coercion variable is simply an Id -- variable of kind @ty1 ~ ty2@. Hence its -- 'varType' is always @PredTy (EqPred t1 t2)@ +type TyCoVar = TyVar -- Something that is a type OR coercion variable. \end{code} %************************************************************************ @@ -136,8 +127,7 @@ data Var realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed - varType :: Kind, -- ^ The type or kind of the 'Var' in question - isCoercionVar :: Bool + varType :: Kind -- ^ The type or kind of the 'Var' in question } | TcTyVar { -- Used only during type inference @@ -187,9 +177,8 @@ instance Outputable Var where ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) ppr_debug :: Var -> SDoc -ppr_debug (TyVar { isCoercionVar = False }) = ptext (sLit "tv") -ppr_debug (TyVar { isCoercionVar = True }) = ptext (sLit "co") -ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d +ppr_debug (TyVar {}) = ptext (sLit "tv") +ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d ppr_id_scope :: IdScope -> SDoc @@ -270,11 +259,9 @@ setTyVarKind tv k = tv {varType = k} \begin{code} mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = ASSERT( not (isCoercionKind kind ) ) - TyVar { varName = name +mkTyVar name kind = TyVar { varName = name , realUnique = getKeyFastInt (nameUnique name) , varType = kind - , isCoercionVar = False } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar @@ -296,36 +283,6 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details } %************************************************************************ %* * -\subsection{Coercion variables} -%* * -%************************************************************************ - -\begin{code} -coVarName :: CoVar -> Name -coVarName = varName - -setCoVarUnique :: CoVar -> Unique -> CoVar -setCoVarUnique = setVarUnique - -setCoVarName :: CoVar -> Name -> CoVar -setCoVarName = setVarName - -mkCoVar :: Name -> Kind -> CoVar -mkCoVar name kind = ASSERT( isCoercionKind kind ) - TyVar { varName = name - , realUnique = getKeyFastInt (nameUnique name) - , varType = kind - , isCoercionVar = True - } - -mkWildCoVar :: Kind -> TyVar --- ^ Create a type variable that is never referred to, so its unique doesn't --- matter -mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild")) -\end{code} - -%************************************************************************ -%* * \subsection{Ids} %* * %************************************************************************ @@ -349,6 +306,10 @@ mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkLocalVar details name ty info = mk_id name ty (LocalId NotExported) details info +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo + -- | Exported 'Var's will not be removed as dead code mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkExportedLocalVar details name ty info @@ -394,20 +355,11 @@ setIdNotExported id = ASSERT( isLocalId id ) %************************************************************************ \begin{code} -isTyCoVar :: Var -> Bool -- True of both type and coercion variables -isTyCoVar (TyVar {}) = True -isTyCoVar (TcTyVar {}) = True -isTyCoVar _ = False - -isTyVar :: Var -> Bool -- True of both type variables only -isTyVar v@(TyVar {}) = not (isCoercionVar v) +isTyVar :: Var -> Bool -- True of both type variables only +isTyVar (TyVar {}) = True isTyVar (TcTyVar {}) = True isTyVar _ = False -isCoVar :: Var -> Bool -- Only works after type checking (sigh) -isCoVar v@(TyVar {}) = isCoercionVar v -isCoVar _ = False - isTcTyVar :: Var -> Bool isTcTyVar (TcTyVar {}) = True isTcTyVar _ = False diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index f275714e5c..fca625692f 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -6,7 +6,7 @@ \begin{code} module VarEnv ( -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, + VarEnv, IdEnv, TyVarEnv, CoVarEnv, -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, @@ -29,7 +29,7 @@ module VarEnv ( emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, + unionInScope, elemInScopeSet, uniqAway, -- * The RnEnv2 type RnEnv2, @@ -343,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) type VarEnv elt = UniqFM elt type IdEnv elt = VarEnv elt type TyVarEnv elt = VarEnv elt +type CoVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs index 6f03aad1bf..e0ff52d690 100644 --- a/compiler/basicTypes/VarSet.lhs +++ b/compiler/basicTypes/VarSet.lhs @@ -6,7 +6,7 @@ \begin{code} module VarSet ( -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, + VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet, -- ** Manipulating these sets emptyVarSet, unitVarSet, mkVarSet, @@ -22,7 +22,7 @@ module VarSet ( #include "HsVersions.h" -import Var ( Var, TyVar, Id ) +import Var ( Var, TyVar, CoVar, TyCoVar, Id ) import Unique import UniqSet \end{code} @@ -37,6 +37,8 @@ import UniqSet type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar +type TyCoVarSet = UniqSet TyCoVar +type CoVarSet = UniqSet CoVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index b9f6db3982..64c77beb15 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -XNoMonoLocalBinds #-} -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course + module CmmCPS ( -- | Converts C-- with full proceedures and parameters -- to a CPS transformed C-- with the stack made manifest. diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 678c961c18..0fa1c381e9 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -29,6 +29,7 @@ import BasicTypes import Unique import Outputable import FastString +import Pair \end{code} %************************************************************************ @@ -79,11 +80,13 @@ exprArity e = go e go (Lam x e) | isId x = go e + 1 | otherwise = go e go (Note n e) | notSccNote n = go e - go (Cast e co) = go e `min` length (typeArity (snd (coercionKind co))) - -- Note [exprArity invariant] + go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co))) + -- Note [exprArity invariant] go (App e (Type _)) = go e go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + go _ = 0 @@ -549,7 +552,7 @@ arityType cheap_fn (Lam x e) | isId x = arityLam x (arityType cheap_fn e) | otherwise = arityType cheap_fn e - -- Applications; decrease arity + -- Applications; decrease arity, except for types arityType cheap_fn (App fun (Type _)) = arityType cheap_fn fun arityType cheap_fn (App fun arg ) @@ -663,14 +666,14 @@ etaExpand n orig_expr -- Strip off existing lambdas and casts -- Note [Eta expansion and SCCs] go 0 expr = expr - go n (Lam v body) | isTyCoVar v = Lam v (go n body) - | otherwise = Lam v (go (n-1) body) + go n (Lam v body) | isTyVar v = Lam v (go n body) + | otherwise = Lam v (go (n-1) body) go n (Cast expr co) = Cast (go n expr) co go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ etaInfoAbs etas (etaInfoApp subst' expr etas) where in_scope = mkInScopeSet (exprFreeVars expr) - (in_scope', etas) = mkEtaWW n in_scope (exprType expr) + (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) subst' = mkEmptySubst in_scope' -- Wrapper Unwrapper @@ -685,10 +688,10 @@ instance Outputable EtaInfo where pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] pushCoercion co1 (EtaCo co2 : eis) - | isIdentityCoercion co = eis - | otherwise = EtaCo co : eis + | isReflCo co = eis + | otherwise = EtaCo co : eis where - co = co1 `mkTransCoercion` co2 + co = co1 `mkTransCo` co2 pushCoercion co eis = EtaCo co : eis @@ -696,7 +699,7 @@ pushCoercion co eis = EtaCo co : eis etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr etaInfoAbs [] expr = expr etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) -etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co) +etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) -------------- etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr @@ -704,15 +707,12 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr -- ((substExpr s e) `appliedto` eis) etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) - = etaInfoApp subst' e eis - where - subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) - | otherwise = CoreSubst.extendIdSubst subst v1 (Var v2) + = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis etaInfoApp subst (Cast e co1) eis = etaInfoApp subst e (pushCoercion co' eis) where - co' = CoreSubst.substTy subst co1 + co' = CoreSubst.substCo subst co1 etaInfoApp subst (Case e b _ alts) eis = Case (subst_expr subst e) b1 (coreAltsType alts') alts' @@ -739,24 +739,24 @@ etaInfoApp subst e eis go e (EtaCo co : eis) = go (Cast e co) eis -------------- -mkEtaWW :: Arity -> InScopeSet -> Type +mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type -> (InScopeSet, [EtaInfo]) -- EtaInfo contains fresh variables, -- not free in the incoming CoreExpr -- Outgoing InScopeSet includes the EtaInfo vars -- and the original free vars -mkEtaWW orig_n in_scope orig_ty +mkEtaWW orig_n orig_expr in_scope orig_ty = go orig_n empty_subst orig_ty [] where - empty_subst = mkTvSubst in_scope emptyTvSubstEnv + empty_subst = TvSubst in_scope emptyTvSubstEnv go n subst ty eis -- See Note [exprArity invariant] | n == 0 = (getTvInScope subst, reverse eis) | Just (tv,ty') <- splitForAllTy_maybe ty - , let (subst', tv') = substTyVarBndr subst tv + , let (subst', tv') = Type.substTyVarBndr subst tv -- Avoid free vars of the original expression = go n subst' ty' (EtaVar tv' : eis) @@ -772,11 +772,11 @@ mkEtaWW orig_n in_scope orig_ty -- eta_expand 1 e T -- We want to get -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - go n subst ty' (EtaCo (Type.substTy subst co) : eis) + go n subst ty' (EtaCo co : eis) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function. - = WARN( True, ppr orig_n <+> ppr orig_ty ) + = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) (getTvInScope subst, reverse eis) -- This *can* legitmately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index af414f7550..81bd6cdeb1 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -49,6 +49,7 @@ import Name import VarSet import Var import TcType +import Coercion import Util import BasicTypes( Activation ) import Outputable @@ -179,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) = someVars (tyVarsOfType ty) +expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) expr_fvs (Var var) = oneVar var expr_fvs (Lit _) = noVars expr_fvs (Note _ expr) = expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) -expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyVarsOfType co) +expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) expr_fvs (Case scrut bndr ty alts) = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr @@ -248,10 +250,11 @@ exprOrphNames e where n = idName v go (Lit _) = emptyNameSet go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co go (App e1 e2) = go e1 `unionNameSets` go e2 go (Lam v e) = go e `delFromNameSet` idName v go (Note _ e) = go e - go (Cast e co) = go e `unionNameSets` orphNamesOfType co + go (Cast e co) = go e `unionNameSets` orphNamesOfCo co go (Let (NonRec _ r) e) = go e `unionNameSets` go r go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty @@ -392,15 +395,15 @@ varTypeTyVars :: Var -> TyVarSet -- Find the type variables free in the type of the variable -- Remember, coercion variables can mention type variables... varTypeTyVars var - | isLocalId var || isCoVar var = tyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars + | isLocalId var = tyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars varTypeTcTyVars :: Var -> TyVarSet -- Find the type variables free in the type of the variable -- Remember, coercion variables can mention type variables... varTypeTcTyVars var - | isLocalId var || isCoVar var = tcTyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars + | isLocalId var = tcTyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars idFreeVars :: Id -> VarSet -- Type variables, rule variables, and inline variables @@ -411,7 +414,7 @@ idFreeVars id = ASSERT( isId id) bndrRuleAndUnfoldingVars ::Var -> VarSet -- A 'let' can bind a type variable, and idRuleVars assumes -- it's seeing an Id. This function tests first. -bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet | otherwise = idRuleAndUnfoldingVars v idRuleAndUnfoldingVars :: Id -> VarSet @@ -515,7 +518,7 @@ freeVars (Cast expr co) = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co) where expr2 = freeVars expr - cfvs = tyVarsOfType co + cfvs = tyCoVarsOfCo co freeVars (Note other_note expr) = (freeVarsOf expr2, AnnNote other_note expr2) @@ -523,5 +526,7 @@ freeVars (Note other_note expr) expr2 = freeVars expr freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) + +freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) \end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 5cc82a2ae2..28e09ae40f 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -15,6 +15,7 @@ import Demand import CoreSyn import CoreFVs import CoreUtils +import Pair import Bag import Literal import DataCon @@ -27,6 +28,7 @@ import Id import PprCore import ErrUtils import SrcLoc +import Kind import Type import TypeRep import Coercion @@ -41,6 +43,7 @@ import FastString import Util import Control.Monad import Data.Maybe +import Data.Traversable (traverse) \end{code} %************************************************************************ @@ -166,7 +169,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check the rhs do { ty <- lintCoreExpr rhs ; lintBinder binder -- Check match to RHS type - ; binder_ty <- applySubst binder_ty + ; binder_ty <- applySubstTy binder_ty ; checkTys binder_ty ty (mkRhsMsg binder ty) -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) ; checkL (not (isUnLiftedType binder_ty) @@ -207,14 +210,15 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) %************************************************************************ \begin{code} -type InType = Type -- Substitution not yet applied -type InVar = Var -type InTyVar = TyVar +type InType = Type -- Substitution not yet applied +type InCoercion = Coercion +type InVar = Var +type InTyVar = TyVar -type OutType = Type -- Substitution has been applied to this -type OutVar = Var -type OutTyVar = TyVar -type OutCoVar = CoVar +type OutType = Type -- Substitution has been applied to this +type OutCoercion = Coercion +type OutVar = Var +type OutTyVar = TyVar lintCoreExpr :: CoreExpr -> LintM OutType -- The returned type has the substitution from the monad @@ -227,6 +231,9 @@ lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) + ; checkL (isId var && not (isCoVar var)) + (ptext (sLit "Non term variable") <+> ppr var) + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -236,7 +243,7 @@ lintCoreExpr (Lit lit) lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr - ; co' <- applySubst co + ; co' <- applySubstCo co ; (from_ty, to_ty) <- lintCoercion co' ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) ; return to_ty } @@ -251,29 +258,20 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) ; lintTyBndr tv $ \ tv' -> addLoc (BodyOfLetRec [tv]) $ extendSubstL tv' ty' $ do - { checkKinds tv' ty' + { checkTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body ; lintCoreExpr body } } - | isCoVar tv - = do { co <- applySubst ty - ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co - ; lintTyBndr tv $ \ tv' -> - addLoc (BodyOfLetRec [tv]) $ do - { let (t1,t2) = coVarKind tv' - ; checkTys s1 t1 (mkTyVarLetErr tv ty) - ; checkTys s2 t2 (mkTyVarLetErr tv ty) - ; lintCoreExpr body } } - - | otherwise - = failWithL (mkTyVarLetErr tv ty) -- Not quite accurate - lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) - ; addLoc (BodyOfLetRec [bndr]) + ; addLoc (BodyOfLetRec [bndr]) (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> do { checkL (null dups) (dupVars dups) @@ -298,7 +296,7 @@ lintCoreExpr (Lam var expr) else return (mkForAllTy var' body_ty) } - -- The applySubst is needed to apply the subst to var + -- The applySubstTy is needed to apply the subst to var lintCoreExpr e@(Case scrut var alt_ty alts) = -- Check the scrutinee @@ -338,6 +336,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = lintCoreExpr (Type ty) = do { ty' <- lintInTy ty ; return (typeKind ty') } + +lintCoreExpr (Coercion co) + = do { co' <- lintInCo co + ; let Pair ty1 ty2 = coercionKind co' + ; return (mkPredTy $ EqPred ty1 ty2) } \end{code} %************************************************************************ @@ -352,12 +355,12 @@ subtype of the required type, as one would expect. \begin{code} lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg fun_ty (Type arg_ty) - = do { arg_ty' <- applySubst arg_ty - ; lintTyApp fun_ty arg_ty' } + = do { arg_ty' <- applySubstTy arg_ty + ; lintTyApp fun_ty arg_ty' } lintCoreArg fun_ty arg - = do { arg_ty <- lintCoreExpr arg - ; lintValApp arg fun_ty arg_ty } + = do { arg_ty <- lintCoreExpr arg + ; lintValApp arg fun_ty arg_ty } ----------------- lintAltBinders :: OutType -- Scrutinee type @@ -367,7 +370,7 @@ lintAltBinders :: OutType -- Scrutinee type lintAltBinders scrut_ty con_ty [] = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) lintAltBinders scrut_ty con_ty (bndr:bndrs) - | isTyCoVar bndr + | isTyVar bndr = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) ; lintAltBinders scrut_ty con_ty' bndrs } | otherwise @@ -378,11 +381,10 @@ lintAltBinders scrut_ty con_ty (bndr:bndrs) lintTyApp :: OutType -> OutType -> LintM OutType lintTyApp fun_ty arg_ty | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty - = do { checkKinds tyvar arg_ty - ; if isCoVar tyvar then - return body_ty -- Co-vars don't appear in body_ty! - else - return (substTyWith [tyvar] [arg_ty] body_ty) } + , isTyVar tyvar + = do { checkTyKind tyvar arg_ty + ; return (substTyWith [tyvar] [arg_ty] body_ty) } + | otherwise = failWithL (mkTyAppMsg fun_ty arg_ty) @@ -400,22 +402,34 @@ lintValApp arg fun_ty arg_ty \end{code} \begin{code} -checkKinds :: OutVar -> OutType -> LintM () +checkTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied -checkKinds tyvar arg_ty +checkTyKind tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. - | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty - ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2) - (addErrL (mkCoAppErrMsg tyvar arg_ty)) } - | otherwise = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `isSubKind` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty)) } + = do { arg_kind <- lintType arg_ty + ; unless (arg_kind `isSubKind` tyvar_kind) + (addErrL (mkKindErrMsg tyvar arg_ty)) } where tyvar_kind = tyVarKind tyvar - (s1,t1) = coVarKind tyvar + +-- Check that the kinds of a type variable and a coercion match, that +-- is, if tv :: k then co :: t1 ~ t2 where t1 :: k and t2 :: k. +checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType) +checkTyCoKind tv co + = do { (t1,t2) <- lintCoercion co + ; k1 <- lintType t1 + ; k2 <- lintType t2 + ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind)) + (addErrL (mkTyCoAppErrMsg tv co)) + ; return (t1,t2) } + where + tyvar_kind = tyVarKind tv + +checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)] +checkTyCoKinds = zipWithM checkTyCoKind checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... @@ -536,7 +550,7 @@ lintBinder var linterF lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a lintTyBndr tv thing_inside = do { subst <- getTvSubst - ; let (subst', tv') = substTyVarBndr subst tv + ; let (subst', tv') = Type.substTyVarBndr subst tv ; lintTyBndrKind tv' ; updateTvSubst subst' (thing_inside tv') } @@ -581,10 +595,19 @@ lintInTy :: InType -> LintM OutType -- ToDo: check the kind structure of the type lintInTy ty = addLoc (InType ty) $ - do { ty' <- applySubst ty + do { ty' <- applySubstTy ty ; _ <- lintType ty' ; return ty' } +lintInCo :: InCoercion -> LintM OutCoercion +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; _ <- lintCoercion co' + ; return co' } + ------------------- lintKind :: Kind -> LintM () -- Check well-formedness of kinds: *, *->*, etc @@ -598,124 +621,85 @@ lintKind kind ------------------- lintTyBndrKind :: OutTyVar -> LintM () -lintTyBndrKind tv - | isCoVar tv = lintCoVarKind tv - | otherwise = lintKind (tyVarKind tv) +lintTyBndrKind tv = lintKind (tyVarKind tv) ------------------- -lintCoVarKind :: OutCoVar -> LintM () --- Check the kind of a coercion binder -lintCoVarKind tv - = do { (ty1,ty2) <- lintSplitCoVar tv - ; k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; unless (k1 `eqKind` k2) - (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:") - , nest 2 (quotes (ppr tv)) - , ppr [k1,k2] ])) } - -------------------- -lintSplitCoVar :: CoVar -> LintM (Type,Type) -lintSplitCoVar cv - = case coVarKind_maybe cv of - Just ts -> return ts - Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") - , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) - -------------------- -lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType) +lintCoercion :: OutCoercion -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind -lintCoercion co - = addLoc (InCoercion co) $ lintCoercion' co - -lintCoercion' ty@(TyVarTy tv) - = do { checkTyVarInScope tv - ; if isCoVar tv then return (coVarKind tv) - else return (ty, ty) } - -lintCoercion' ty@(AppTy ty1 ty2) - = do { (s1,t1) <- lintCoercion ty1 - ; (s2,t2) <- lintCoercion ty2 - ; check_co_app ty (typeKind s1) [s2] - ; return (mkAppTy s1 s2, mkAppTy t1 t2) } - -lintCoercion' ty@(FunTy ty1 ty2) - = do { (s1,t1) <- lintCoercion ty1 - ; (s2,t2) <- lintCoercion ty2 - ; check_co_app ty (tyConKind funTyCon) [s1, s2] - ; return (FunTy s1 s2, FunTy t1 t2) } +lintCoercion (Refl ty) + = do { ty' <- lintInTy ty + ; return (ty', ty') } -lintCoercion' ty@(TyConApp tc tys) - | Just (ar, desc) <- isCoercionTyCon_maybe tc - = do { unless (tys `lengthAtLeast` ar) (badCo ty) - ; (s,t) <- lintCoTyConApp ty desc (take ar tys) - ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys) - ; check_co_app ty (typeKind s) ss - ; return (mkAppTys s ss, mkAppTys t ts) } +lintCoercion co@(TyConAppCo tc cos) + = do { (ss,ts) <- mapAndUnzipM lintCoercion cos + ; check_co_app co (tyConKind tc) ss + ; return (mkTyConApp tc ss, mkTyConApp tc ts) } - | not (tyConHasKind tc) -- Just something bizarre like SuperKindTyCon - = badCo ty +lintCoercion co@(AppCo co1 co2) + = do { (s1,t1) <- lintCoercion co1 + ; (s2,t2) <- lintCoercion co2 + ; check_co_app co (typeKind s1) [s2] + ; return (mkAppTy s1 s2, mkAppTy t1 t2) } - | otherwise - = do { (ss,ts) <- mapAndUnzipM lintCoercion tys - ; check_co_app ty (tyConKind tc) ss - ; return (TyConApp tc ss, TyConApp tc ts) } +lintCoercion (ForAllCo v co) + = do { lintKind (tyVarKind v) + ; (s,t) <- addInScopeVar v (lintCoercion co) + ; return (ForAllTy v s, ForAllTy v t) } -lintCoercion' ty@(PredTy (ClassP cls tys)) - = do { (ss,ts) <- mapAndUnzipM lintCoercion tys - ; check_co_app ty (tyConKind (classTyCon cls)) ss +lintCoercion co@(PredCo (ClassP cls cos)) + = do { (ss,ts) <- mapAndUnzipM lintCoercion cos + ; check_co_app co (tyConKind (classTyCon cls)) ss ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) } -lintCoercion' (PredTy (IParam n p_ty)) - = do { (s,t) <- lintCoercion p_ty - ; return (PredTy (IParam n s), PredTy (IParam n t)) } - -lintCoercion' ty@(PredTy (EqPred {})) - = failWithL (badEq ty) - -lintCoercion' (ForAllTy tv ty) - | isCoVar tv - = do { (co1, co2) <- lintSplitCoVar tv - ; (s1,t1) <- lintCoercion co1 - ; (s2,t2) <- lintCoercion co2 - ; (sr,tr) <- lintCoercion ty - ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) } - - | otherwise - = do { lintKind (tyVarKind tv) - ; (s,t) <- addInScopeVar tv (lintCoercion ty) - ; return (ForAllTy tv s, ForAllTy tv t) } - -badCo :: Coercion -> LintM a -badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co)) - ---------------- -lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type) --- Always called with correct number of coercion arguments --- First arg is just for error message -lintCoTyConApp _ CoLeft (co:_) = lintLR fst co -lintCoTyConApp _ CoRight (co:_) = lintLR snd co -lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3 co -lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3 co -lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co - -lintCoTyConApp _ CoSym (co:_) - = do { (ty1,ty2) <- lintCoercion co - ; return (ty2,ty1) } - -lintCoTyConApp co CoTrans (co1:co2:_) +lintCoercion (PredCo (IParam ip co)) + = do { (s,t) <- lintCoercion co + ; return (PredTy (IParam ip s), PredTy (IParam ip t)) } + +lintCoercion (PredCo (EqPred c1 c2)) + = do { (s1,t1) <- lintCoercion c1 + ; (s2,t2) <- lintCoercion c2 + ; return (PredTy (EqPred s1 s2), PredTy (EqPred t1 t2)) } + +lintCoercion (CoVarCo cv) + = do { checkTyCoVarInScope cv + ; return (coVarKind cv) } + +lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs + , co_ax_lhs = lhs + , co_ax_rhs = rhs }) + cos) + = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos) + ; return (substTyWith tvs tys1 lhs, + substTyWith tvs tys2 rhs) } + +lintCoercion (UnsafeCo ty1 ty2) + = do { ty1' <- lintInTy ty1 + ; ty2' <- lintInTy ty2 + ; return (ty1', ty2') } + +lintCoercion (SymCo co) + = do { (ty1, ty2) <- lintCoercion co + ; return (ty2, ty1) } + +lintCoercion co@(TransCo co1 co2) = do { (ty1a, ty1b) <- lintCoercion co1 ; (ty2a, ty2b) <- lintCoercion co2 - ; checkL (ty1b `coreEqType` ty2a) + ; checkL (ty1b `eqType` ty2a) (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) ; return (ty1a, ty2b) } -lintCoTyConApp _ CoInst (co:arg_ty:_) - = do { co_tys <- lintCoercion co +lintCoercion the_co@(NthCo d co) + = do { (s,t) <- lintCoercion co + ; sn <- checkTcApp the_co d s + ; tn <- checkTcApp the_co d t + ; return (sn, tn) } + +lintCoercion (InstCo co arg_ty) + = do { co_tys <- lintCoercion co ; arg_kind <- lintType arg_ty - ; case decompInst_maybe co_tys of - Just ((tv1,tv2), (ty1,ty2)) + ; case splitForAllTy_maybe `traverse` toPair co_tys of + Just (Pair (tv1,ty1) (tv2,ty2)) | arg_kind `isSubKind` tyVarKind tv1 -> return (substTyWith [tv1] [arg_ty] ty1, substTyWith [tv2] [arg_ty] ty2) @@ -723,40 +707,20 @@ lintCoTyConApp _ CoInst (co:arg_ty:_) -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } -lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos - = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos - ; sequence_ (zipWith checkKinds tvs tys1) - ; return (substTyWith tvs tys1 lhs_ty, - substTyWith tvs tys2 rhs_ty) } - -lintCoTyConApp _ CoUnsafe (ty1:ty2:_) - = do { _ <- lintType ty1 - ; _ <- lintType ty2 -- Ignore kinds; it's unsafe! - ; return (ty1,ty2) } - -lintCoTyConApp _ _ _ = panic "lintCoTyConApp" -- Called with wrong number of coercion args - ----------- -lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type) -lintLR sel co - = do { (ty1,ty2) <- lintCoercion co - ; case decompLR_maybe (ty1,ty2) of - Just res -> return (sel res) - Nothing -> failWithL (ptext (sLit "Bad argument of left/right")) } - ---------- -lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type) -lintCsel sel co - = do { (ty1,ty2) <- lintCoercion co - ; case decompCsel_maybe (ty1,ty2) of - Just res -> return (sel res) - Nothing -> failWithL (ptext (sLit "Bad argument of csel")) } +checkTcApp :: Coercion -> Int -> Type -> LintM Type +checkTcApp co n ty + | Just (_, tys) <- splitTyConApp_maybe ty + , n < length tys + = return (tys !! n) + | otherwise + = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) + 2 (ptext (sLit "Offending type:") <+> ppr ty)) ------------------- lintType :: OutType -> LintM Kind lintType (TyVarTy tv) - = do { checkTyVarInScope tv + = do { checkTyCoVarInScope tv ; return (tyVarKind tv) } lintType ty@(AppTy t1 t2) @@ -782,8 +746,13 @@ lintType ty@(PredTy (ClassP cls tys)) lintType (PredTy (IParam _ p_ty)) = lintType p_ty -lintType ty@(PredTy (EqPred {})) - = failWithL (badEq ty) +lintType ty@(PredTy (EqPred t1 t2)) + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; unless (k1 `eqKind` k2) + (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:") + , nest 2 (ppr ty) ])) + ; return unliftedTypeKind } ---------------- lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind @@ -812,10 +781,6 @@ lint_kind_app doc kfn ks = go kfn ks Just (kfa, kfb) -> do { unless (k `isSubKind` kfa) (addErrL fail_msg) ; go kfb ks } --------------- -badEq :: Type -> SDoc -badEq ty = hang (ptext (sLit "Unexpected equality predicate:")) - 1 (quotes (ppr ty)) \end{code} %************************************************************************ @@ -870,7 +835,7 @@ data LintLocInfo | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) | TopLevelBindings | InType Type -- Inside a type - | InCoercion Coercion -- Inside a type + | InCo Coercion -- Inside a coercion \end{code} @@ -936,12 +901,15 @@ updateTvSubst subst' m = getTvSubst :: LintM TvSubst getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) -applySubst :: Type -> LintM Type -applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) } +applySubstTy :: Type -> LintM Type +applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } + +applySubstCo :: Coercion -> LintM Coercion +applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) } extendSubstL :: TyVar -> Type -> LintM a -> LintM a extendSubstL tv ty m - = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs) + = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs) \end{code} \begin{code} @@ -969,8 +937,8 @@ checkBndrIdInScope binder id msg = ptext (sLit "is out of scope inside info for") <+> ppr binder -checkTyVarInScope :: TyVar -> LintM () -checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv +checkTyCoVarInScope :: TyCoVar -> LintM () +checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var = @@ -982,7 +950,7 @@ checkTys :: OutType -> OutType -> Message -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied -checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg +checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg \end{code} %************************************************************************ @@ -1021,8 +989,8 @@ dumpLoc TopLevelBindings = (noSrcLoc, empty) dumpLoc (InType ty) = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InCoercion ty) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) @@ -1114,29 +1082,21 @@ mkNonFunAppMsg fun_ty arg_ty arg hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkTyVarLetErr :: TyVar -> Type -> Message -mkTyVarLetErr tyvar ty - = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"), - hang (ptext (sLit "Type/coercion variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg type/coercion:")) - 4 (ppr ty)] - -mkKindErrMsg :: TyVar -> Type -> Message -mkKindErrMsg tyvar arg_ty - = vcat [ptext (sLit "Kinds don't match in type application:"), - hang (ptext (sLit "Type variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg type:")) - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkCoAppErrMsg :: TyVar -> Type -> Message -mkCoAppErrMsg tyvar arg_ty - = vcat [ptext (sLit "Kinds don't match in coercion application:"), - hang (ptext (sLit "Coercion variable:")) +mkLetErr :: TyVar -> CoreExpr -> Message +mkLetErr bndr rhs + = vcat [ptext (sLit "Bad `let' binding:"), + hang (ptext (sLit "Variable:")) + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (ptext (sLit "Rhs:")) + 4 (ppr rhs)] + +mkTyCoAppErrMsg :: TyVar -> Coercion -> Message +mkTyCoAppErrMsg tyvar arg_co + = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), + hang (ptext (sLit "Type variable:")) 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), hang (ptext (sLit "Arg coercion:")) - 4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))] + 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] mkTyAppMsg :: Type -> Type -> Message mkTyAppMsg ty arg_ty @@ -1168,6 +1128,15 @@ mkStrictMsg binder hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] ] + +mkKindErrMsg :: TyVar -> Type -> Message +mkKindErrMsg tyvar arg_ty + = vcat [ptext (sLit "Kinds don't match in type application:"), + hang (ptext (sLit "Type variable:")) + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (ptext (sLit "Arg type:")) + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + mkArityMsg :: Id -> Message mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has "), @@ -1203,3 +1172,56 @@ dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) \end{code} + +-------------- DEAD CODE ------------------- + +------------------- +checkCoKind :: CoVar -> OutCoercion -> LintM () +-- Both args have had substitution applied +checkCoKind covar arg_co + = do { (s2,t2) <- lintCoercion arg_co + ; unless (s1 `eqType` s2 && t1 `coreEqType` t2) + (addErrL (mkCoAppErrMsg covar arg_co)) } + where + (s1,t1) = coVarKind covar + +lintCoVarKind :: OutCoVar -> LintM () +-- Check the kind of a coercion binder +lintCoVarKind tv + = do { (ty1,ty2) <- lintSplitCoVar tv + ; lintEqType ty1 ty2 + + +------------------- +lintSplitCoVar :: CoVar -> LintM (Type,Type) +lintSplitCoVar cv + = case coVarKind_maybe cv of + Just ts -> return ts + Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") + , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) + +mkCoVarLetErr :: CoVar -> Coercion -> Message +mkCoVarLetErr covar co + = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), + hang (ptext (sLit "Coercion variable:")) + 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), + hang (ptext (sLit "Arg coercion:")) + 4 (ppr co)] + +mkCoAppErrMsg :: CoVar -> Coercion -> Message +mkCoAppErrMsg covar arg_co + = vcat [ptext (sLit "Kinds don't match in coercion application:"), + hang (ptext (sLit "Coercion variable:")) + 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), + hang (ptext (sLit "Arg coercion:")) + 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] + + +mkCoAppMsg :: Type -> Coercion -> Message +mkCoAppMsg ty arg_co + = vcat [text "Illegal type application:", + hang (ptext (sLit "exp type:")) + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (ptext (sLit "arg type:")) + 4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))] + diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 42379b4c01..04057160b8 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -37,6 +37,7 @@ import OrdList import ErrUtils import DynFlags import Util +import Pair import Outputable import MonadUtils import FastString @@ -78,9 +79,9 @@ The goal of this pass is to prepare for code generation. weaker guarantee of no clashes which the simplifier provides. And that is what the code generator needs. - We don't clone TyVars. The code gen doesn't need that, + We don't clone TyVars or CoVars. The code gen doesn't need that, and doing so would be tiresome because then we'd need - to substitute in types. + to substitute in types and coercions. 7. Give each dynamic CCall occurrence a fresh unique; this is @@ -104,19 +105,21 @@ Invariants Here is the syntax of the Core produced by CorePrep: Trivial expressions - triv ::= lit | var | triv ty | /\a. triv | triv |> co + triv ::= lit | var + | triv ty | /\a. triv + | truv co | /\c. triv | triv |> co Applications - app ::= lit | var | app triv | app ty | app |> co + app ::= lit | var | app triv | app ty | app co | app |> co Expressions body ::= app | let(rec) x = rhs in body -- Boxed only | case body of pat -> body - | /\a. body + | /\a. body | /\c. body | body |> co - Right hand sides (only place where lambdas can occur) + Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body We define a synonym for each of these non-terminals. Functions @@ -440,9 +443,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE _env expr@(Type _) = return (emptyFloats, expr) -cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env (Var f `App` _ `App` arg) | f `hasKey` lazyIdKey -- Replace (lazy a) by a @@ -528,7 +532,7 @@ rhsToBody (Cast e co) rhsToBody expr@(Lam {}) | Just no_lam_result <- tryEtaReducePrep bndrs body = return (emptyFloats, no_lam_result) - | all isTyCoVar bndrs -- Type lambdas are ok + | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) | otherwise -- Some value lambdas = do { fn <- newVar (exprType expr) @@ -579,6 +583,10 @@ cpeApp env expr = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } + collect_args (App fun arg@(Coercion arg_co)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) } + collect_args (App fun arg) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) ; let @@ -608,7 +616,7 @@ cpeApp env expr -- partial application might be seq'd collect_args (Cast fun co) depth - = do { let (_ty1,ty2) = coercionKind co + = do { let Pair _ty1 ty2 = coercionKind co ; (fun', hd, _, floats, ss) <- collect_args fun depth ; return (Cast fun' co, hd, ty2, floats, ss) } @@ -751,11 +759,12 @@ cpe_ExprIsTrivial :: CoreExpr -> Bool -- Version that doesn't consider an scc annotation to be trivial. cpe_ExprIsTrivial (Var _) = True cpe_ExprIsTrivial (Type _) = True +cpe_ExprIsTrivial (Coercion _) = True cpe_ExprIsTrivial (Lit _) = True cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e -cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body +cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body cpe_ExprIsTrivial _ = False \end{code} @@ -1070,7 +1079,7 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cloneBndr env bndr - | isLocalId bndr + | isLocalId bndr, not (isCoVar bndr) = do bndr' <- setVarUnique bndr <$> getUniqueM -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings @@ -1082,7 +1091,7 @@ cloneBndr env bndr | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now - -- And we don't clone tyvars + -- And we don't clone tyvars, or coercion variables = return (env, bndr) diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index a229b8c4e9..047e6c337b 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -12,14 +12,15 @@ module CoreSubst ( -- ** Substituting into expressions and related types deShadowBinds, substSpec, substRulesForImportedIds, - substTy, substExpr, substExprSC, substBind, substBindSC, + substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, - substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc, + substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc, -- ** Operations on substitutions emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, - extendSubst, extendSubstList, zapSubstEnv, + extendCvSubst, extendCvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, isInScope, setInScope, delBndr, delBndrs, @@ -37,18 +38,23 @@ module CoreSubst ( import CoreSyn import CoreFVs import CoreUtils -import PprCore import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) import qualified Type -import Type ( Type, TvSubst(..), TvSubstEnv ) -import Coercion ( isIdentityCoercion ) +import qualified Coercion + + -- We are defining local versions +import Type hiding ( substTy, extendTvSubst, extendTvSubstList + , isInScope, substTyVarBndr ) +import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) + import OptCoercion ( optCoercion ) +import PprCore ( pprCoreBindings ) import VarSet import VarEnv import Id import Name ( Name ) -import Var ( Var, TyVar, setVarUnique ) +import Var import IdInfo import Unique import UniqSupply @@ -92,7 +98,8 @@ data Subst = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ -- applying the substitution IdSubstEnv -- Substitution for Ids - TvSubstEnv -- Substitution for TyVars + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from TyCoVars to Coercions -- INVARIANT 1: See #in_scope_invariant# -- This is what lets us deal with name capture properly @@ -126,6 +133,11 @@ In consequence: * In substIdBndr, we extend the IdSubstEnv only when the unique changes +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + * In lookupIdSubst, we *must* look up the Id in the in-scope set, because it may contain non-trivial changes. Example: (/\a. \x:a. ...x...) Int @@ -140,7 +152,8 @@ In consequence: * (However, we don't need to do so for expressions found in the IdSubst itself, whose range is assumed to be correct wrt the in-scope set.) -Why do we make a different choice for the IdSubstEnv than the TvSubstEnv? +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? * For Ids, we change the IdInfo all the time (e.g. deleting the unfolding), and adding it back later, so using the TyVar convention @@ -158,70 +171,82 @@ type IdSubstEnv = IdEnv CoreExpr ---------------------------- isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv - -mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs ids = Subst in_scope ids tvs - --- getTvSubst :: Subst -> TvSubst --- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv --- getTvSubstEnv :: Subst -> TvSubstEnv --- getTvSubstEnv (Subst _ _ tv_env) = tv_env --- --- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst --- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs -- | Find the in-scope set: see "CoreSubst#in_scope_invariant" substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _) = in_scope +substInScope (Subst in_scope _ _ _) = in_scope -- | Remove all substitutions for 'Id's and 'Var's that might have been built up -- while preserving the in-scope set zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv +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 the "CoreSubst#in_scope_invariant" is true 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 -extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs +extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst -extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs +extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r) +extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) +extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs --- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also --- 'extendIdSubst' and 'extendTvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst -extendSubst (Subst in_scope ids tvs) tv (Type ty) - = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty) -extendSubst (Subst in_scope ids tvs) id expr - = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs +-- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) + +-- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the +-- 'Subst': see also 'extendCvSubst' +extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst +extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) --- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst' +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'. +extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co + _ -> ASSERT( isId var ) extendIdSubst subst var arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst extendSubstList subst [] = subst extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs -- | Find the substitution for an 'Id' in the 'Subst' lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr -lookupIdSubst doc (Subst in_scope ids _) v +lookupIdSubst doc (Subst in_scope ids _ _) v | not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' @@ -231,18 +256,22 @@ lookupIdSubst doc (Subst in_scope ids _) v -- | Find the substitution for a 'TyVar' in the 'Subst' lookupTvSubst :: Subst -> TyVar -> Type -lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v +lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + +-- | Find the coercion substitution for a 'TyCoVar' in the 'Subst' +lookupCvSubst :: Subst -> CoVar -> Coercion +lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v delBndr :: Subst -> Var -> Subst -delBndr (Subst in_scope tvs ids) v - | isId v = Subst in_scope tvs (delVarEnv ids v) - | otherwise = Subst in_scope (delVarEnv tvs v) ids +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs delBndrs :: Subst -> [Var] -> Subst -delBndrs (Subst in_scope tvs ids) vs - = Subst in_scope (delVarEnvList tvs vs_tv) (delVarEnvList ids vs_id) - where - (vs_id, vs_tv) = partition isId vs +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easist thing is just delete all from all! -- | Simultaneously substitute for a bunch of variables -- No left-right shadowing @@ -252,49 +281,51 @@ mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst mkOpenSubst in_scope pairs = Subst in_scope (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) ------------------------------ isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -- | Add the 'Var' to the in-scope set, but do not remove -- any existing substitutions for it addInScopeSet :: Subst -> VarSet -> Subst -addInScopeSet (Subst in_scope ids tvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) ids tvs +addInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs -- | Add the 'Var' to the in-scope set: as a side effect, -- and remove any existing substitutions for it extendInScope :: Subst -> Var -> Subst -extendInScope (Subst in_scope ids tvs) v +extendInScope (Subst in_scope ids tvs cvs) v = Subst (in_scope `extendInScopeSet` v) - (ids `delVarEnv` v) (tvs `delVarEnv` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) -- | Add the 'Var's to the in-scope set: see also 'extendInScope' extendInScopeList :: Subst -> [Var] -> Subst -extendInScopeList (Subst in_scope ids tvs) vs +extendInScopeList (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) + (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) -- | Optimized version of 'extendInScopeList' that can be used if you are certain --- all the things being added are 'Id's and hence none are 'TyVar's +-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's extendInScopeIds :: Subst -> [Id] -> Subst -extendInScopeIds (Subst in_scope ids tvs) vs +extendInScopeIds (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) tvs + (ids `delVarEnvList` vs) tvs cvs setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs \end{code} Pretty printing, for debugging only \begin{code} instance Outputable Subst where - ppr (Subst in_scope ids tvs) + ppr (Subst in_scope ids tvs cvs) = ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) $$ ptext (sLit " IdSubst =") <+> ppr ids $$ ptext (sLit " TvSubst =") <+> ppr tvs + $$ ptext (sLit " CvSubst =") <+> ppr cvs <> char '>' \end{code} @@ -326,10 +357,11 @@ subst_expr subst expr where go (Var v) = lookupIdSubst (text "subst_expr") subst v go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) go (Note note e) = Note (go_note note) (go e) - go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co) + go (Cast e co) = Cast (go e) (substCo subst co) -- Do not optimise even identity coercions -- Reason: substitution applies to the LHS of RULES, and -- if you "optimise" an identity coercion, you may @@ -416,8 +448,9 @@ preserve occ info in rules. -- 'IdInfo' is preserved by this process, although it is substituted into appropriately. substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr - | isTyCoVar bndr = substTyVarBndr subst bndr - | otherwise = substIdBndr (text "var-bndr") subst subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right substBndrs :: Subst -> [Var] -> (Subst, [Var]) @@ -439,9 +472,9 @@ substIdBndr :: SDoc -> (Subst, Id) -- ^ Transformed pair -- NB: unfolding may be zapped -substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ - (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) + (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 @@ -498,8 +531,8 @@ clone_id :: Subst -- Substitution for the IdInfo -> Subst -> (Id, Unique) -- Substitition and Id to transform -> (Subst, Id) -- Transformed pair -clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq) - = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) +clone_id rec_subst subst@(Subst in_scope env tvs cvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 @@ -510,26 +543,40 @@ clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq) %************************************************************************ %* * - Types + Types and Coercions %* * %************************************************************************ -For types we just call the corresponding function in Type, but we have -to repackage the substitution, from a Subst to a TvSubst +For types and coercions we just call the corresponding functions in +Type and Coercion, but we have to repackage the substitution, from a +Subst to a TvSubst. \begin{code} substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env) tv +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of (TvSubst in_scope' tv_env', tv') - -> (Subst in_scope' id_env tv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env, tv') + +substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv + = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (Subst in_scope' id_env tv_env' cv_env', cv') -- | See 'Type.substTy' substTy :: Subst -> Type -> Type substTy subst ty = Type.substTy (getTvSubst subst) ty getTvSubst :: Subst -> TvSubst -getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env +getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv + +getCvSubst :: Subst -> CvSubst +getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getCvSubst subst) co \end{code} @@ -541,8 +588,8 @@ getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env \begin{code} substIdType :: Subst -> Id -> Id -substIdType subst@(Subst _ _ tv_env) id - | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id | otherwise = setIdType id (substTy subst old_ty) -- The tyVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type @@ -555,7 +602,7 @@ substIdType subst@(Subst _ _ tv_env) id substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing - | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules + | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules `setUnfoldingInfo` substUnfolding subst old_unf) where old_rules = specInfo info @@ -594,7 +641,7 @@ substUnfolding _ unf = unf -- NoUnfolding, OtherCon ------------------- substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource -substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr) +substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr) | Just wkr_expr <- lookupVarEnv ids wkr = case wkr_expr of Var w1 -> InlineWrapper w1 @@ -628,7 +675,7 @@ substSpec subst new_id (SpecInfo rules rhs_fvs) where subst_ru_fn = const (idName new_id) new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) - (substVarSet subst rhs_fvs) + (substVarSet subst rhs_fvs) ------------------ substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] @@ -646,7 +693,6 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule -- - Rules for *local* Ids are in the IdInfo for that Id, -- and the ru_fn field is simply replaced by the new name -- of the Id - substRule _ _ rule@(BuiltinRule {}) = rule substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args , ru_fn = fn_name, ru_rhs = rhs @@ -664,7 +710,7 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args ------------------ substVarSet :: Subst -> VarSet -> VarSet -substVarSet subst fvs +substVarSet subst fvs = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs where subst_fv subst fv @@ -713,7 +759,7 @@ simpleOptExpr expr -- won't *be* substituting for x if it occurs inside a -- lambda. -- - -- It's a bit painful to call exprFreeVars, because it makes + -- It's a bit painful to call exprFreeVars, because it makes -- three passes instead of two (occ-anal, and go) simpleOptExprWith :: Subst -> InExpr -> OutExpr @@ -747,19 +793,22 @@ type OutExpr = CoreExpr -- In these functions the substitution maps InVar -> OutExpr ---------------------- -simple_opt_expr :: Subst -> InExpr -> OutExpr -simple_opt_expr subst expr +simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr +simple_opt_expr s e = simple_opt_expr' s e + +simple_opt_expr' subst expr = go expr where go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v go (App e1 e2) = simple_app subst e1 [go e2] - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co) go (Lit lit) = Lit lit go (Note note e) = Note note (go e) - go (Cast e co) | isIdentityCoercion co' = go e - | otherwise = Cast (go e) co' + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' where - co' = substTy subst co + co' = optCoercion (getCvSubst subst) co go (Let bind body) = case simple_opt_bind subst bind of (subst', Nothing) -> simple_opt_expr subst' body @@ -806,21 +855,25 @@ simple_app subst e as = foldl App (simple_opt_expr subst e) as ---------------------- -simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind) -simple_opt_bind subst (Rec prs) - = (subst'', Just (Rec (reverse rev_prs'))) +simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind) +simple_opt_bind s b -- Can add trace stuff here + = simple_opt_bind' s b + +simple_opt_bind' subst (Rec prs) + = (subst'', res_bind) where + res_bind = Just (Rec (reverse rev_prs')) (subst', bndrs') = subst_opt_bndrs subst (map fst prs) (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') do_pr (subst, prs) ((b,r), b') = case maybe_substitute subst b r2 of Just subst' -> (subst', prs) - Nothing -> (subst, (b2,r2):prs) + Nothing -> (subst, (b2,r2):prs) where b2 = add_info subst b b' r2 = simple_opt_expr subst r -simple_opt_bind subst (NonRec b r) +simple_opt_bind' subst (NonRec b r) = case maybe_substitute subst b r' of Just ext_subst -> (ext_subst, Nothing) Nothing -> (subst', Just (NonRec b2 r')) @@ -836,10 +889,14 @@ maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst -- or returns Nothing maybe_substitute subst b r | Type ty <- r -- let a::* = TYPE ty in <body> - = ASSERT( isTyCoVar b ) + = ASSERT( isTyVar b ) Just (extendTvSubst subst b ty) - | isId b -- let x = e in <body> + | Coercion co <- r + = ASSERT( isCoVar b ) + Just (extendCvSubst subst b co) + + | isId b -- let x = e in <body> , safe_to_inline (idOccInfo b) , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] , not (isStableUnfolding (idUnfolding b)) @@ -859,19 +916,20 @@ maybe_substitute subst b r ---------------------- subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) subst_opt_bndr subst bndr - | isTyCoVar bndr = substTyVarBndr subst bndr - | otherwise = subst_opt_id_bndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = subst_opt_id_bndr subst bndr subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId) -- Nuke all fragile IdInfo, unfolding, and RULES; -- it gets added back later by add_info -- Rather like SimplEnv.substIdBndr -- --- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr +-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr -- carefully does not do) because simplOptExpr invalidates it -subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id - = (Subst new_in_scope new_id_subst tv_subst, new_id) +subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id + = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id) where id1 = uniqAway in_scope old_id id2 = setIdType id1 (substTy subst (idType old_id)) @@ -894,9 +952,9 @@ subst_opt_bndrs subst bndrs ---------------------- add_info :: Subst -> InVar -> OutVar -> OutVar -add_info subst old_bndr new_bndr - | isTyCoVar old_bndr = new_bndr - | otherwise = maybeModifyIdInfo mb_new_info new_bndr +add_info subst old_bndr new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = maybeModifyIdInfo mb_new_info new_bndr where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) \end{code} @@ -920,3 +978,4 @@ we don't know what phase we're in. Here's an example When inlining 'foo' in 'bar' we want the let-binding for 'inner' to remain visible until Phase 1 + diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 603b745cf2..30adeaddcb 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -15,7 +15,7 @@ module CoreSyn ( -- ** 'Expr' construction mkLets, mkLams, - mkApps, mkTyApps, mkVarApps, + mkApps, mkTyApps, mkCoApps, mkVarApps, mkIntLit, mkIntLitInt, mkWordLit, mkWordLitWord, @@ -23,18 +23,19 @@ module CoreSyn ( mkFloatLit, mkFloatLitFloat, mkDoubleLit, mkDoubleLitDouble, - mkConApp, mkTyBind, + mkConApp, mkTyBind, mkCoBind, varToCoreExpr, varsToCoreExprs, - isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt, + isId, cmpAltCon, cmpAlt, ltAlt, -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, collectArgs, coreExprCc, flattenBinds, - isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, - notSccNote, + isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + notSccNote, -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), @@ -95,7 +96,7 @@ import Util import Data.Data import Data.Word -infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App` +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) \end{code} @@ -239,6 +240,8 @@ data Expr b | Type Type -- ^ A type: this should only show up at the top -- level of an Arg + + | Coercion Coercion -- ^ A coercion deriving (Data, Typeable) -- | Type synonym for expressions that occur in function argument positions. @@ -878,6 +881,8 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where mkApps :: Expr b -> [Arg b] -> Expr b -- | Apply a list of type argument expressions to a function expression in a nested fashion mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b -- | Apply a list of type or value variables to a function expression in a nested fashion mkVarApps :: Expr b -> [Var] -> Expr b -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to @@ -886,6 +891,7 @@ mkConApp :: DataCon -> [Arg b] -> Expr b mkApps f args = foldl App f args mkTyApps f args = foldl (\ e a -> App e (Type a)) f args +mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkConApp con args = mkApps (Var (dataConWorkId con)) args @@ -956,10 +962,16 @@ mkLets binds body = foldr Let body binds mkTyBind :: TyVar -> Type -> CoreBind mkTyBind tv ty = NonRec tv (Type ty) +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately varToCoreExpr :: CoreBndr -> Expr b -varToCoreExpr v | isId v = Var v - | otherwise = Type (mkTyVarTy v) +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = ASSERT( isId v ) Var v varsToCoreExprs :: [CoreBndr] -> [Expr b] varsToCoreExprs vs = map varToCoreExpr vs @@ -1025,7 +1037,7 @@ collectTyAndValBinders expr collectTyBinders expr = go [] expr where - go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e + go tvs (Lam b e) | isTyVar b = go (b:tvs) e go tvs e = (reverse tvs, e) collectValBinders expr @@ -1076,15 +1088,23 @@ isRuntimeVar = isId isRuntimeArg :: CoreExpr -> Bool isRuntimeArg = isValArg --- | Returns @False@ iff the expression is a 'Type' expression at its top level +-- | Returns @False@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level isValArg :: Expr b -> Bool -isValArg (Type _) = False -isValArg _ = True +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False --- | Returns @True@ iff the expression is a 'Type' expression at its top level +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. isTypeArg :: Expr b -> Bool -isTypeArg (Type _) = True -isTypeArg _ = False +isTypeArg (Type {}) = True +isTypeArg _ = False -- | The number of binders that bind values rather than types valBndrCount :: [CoreBndr] -> Int @@ -1114,9 +1134,10 @@ seqExpr (App f a) = seqExpr f `seq` seqExpr a seqExpr (Lam b e) = seqBndr b `seq` seqExpr e seqExpr (Let b e) = seqBind b `seq` seqExpr e seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as -seqExpr (Cast e co) = seqExpr e `seq` seqType co +seqExpr (Cast e co) = seqExpr e `seq` seqCo co seqExpr (Note n e) = seqNote n `seq` seqExpr e -seqExpr (Type t) = seqType t +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co seqExprs :: [CoreExpr] -> () seqExprs [] = () @@ -1173,6 +1194,7 @@ data AnnExpr' bndr annot | AnnCast (AnnExpr bndr annot) Coercion | AnnNote Note (AnnExpr bndr annot) | AnnType Type + | AnnCoercion Coercion -- | A clone of the 'Alt' type but allowing annotation at every tree node type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) @@ -1199,7 +1221,8 @@ deAnnotate :: AnnExpr bndr annot -> Expr bndr deAnnotate (_, e) = deAnnotate' e deAnnotate' :: AnnExpr' bndr annot -> Expr bndr -deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co deAnnotate' (AnnVar v) = Var v deAnnotate' (AnnLit lit) = Lit lit deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 582f873d18..377bfd8c84 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -17,7 +17,7 @@ import CoreSyn import CoreArity import Id import IdInfo -import TcType( tidyType, tidyTyVarBndr ) +import TcType( tidyType, tidyCo, tidyTyVarBndr ) import Var import VarEnv import UniqFM @@ -55,11 +55,12 @@ tidyBind env (Rec prs) ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr tidyExpr env (Var v) = Var (tidyVarOcc env v) -tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) tidyExpr _ (Lit lit) = Lit lit tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) -tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyType env co) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) tidyExpr env (Let b e) = tidyBind env b =: \ (env', b') -> @@ -125,7 +126,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyCoVar var = tidyTyVarBndr env var + | isTyVar var = tidyTyVarBndr env var | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index d1b9fa0412..5883013a06 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -60,6 +60,7 @@ import PrelNames import VarEnv ( mkInScopeSet ) import Bag import Util +import Pair import FastTypes import FastString import Outputable @@ -107,7 +108,7 @@ mkWwInlineRule id expr arity mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded = mkCoreUnfolding InlineCompulsory True - expr 0 -- Arity of unfolding doesn't matter + (simpleOptExpr expr) 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding @@ -348,11 +349,13 @@ sizeExpr bOMB_OUT_SIZE top_args expr size_up (Cast e _) = size_up e size_up (Note _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) size_up (Var f) = size_up_call f [] -- Make sure we get constructor -- discounts even on nullary constructors size_up (App fun (Type _)) = size_up fun + size_up (App fun (Coercion _)) = size_up fun size_up (App fun arg) = size_up arg `addSizeNSD` size_up_app fun [arg] @@ -408,7 +411,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr ------------ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args - | isTypeArg arg = size_up_app fun args + | isTyCoArg arg = size_up_app fun args | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) size_up_app (Var fun) args = size_up_call fun args @@ -1147,12 +1150,14 @@ interestingArg e = go e 0 conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg - go (App fn (Type _)) n = go fn n + go (Coercion _) _ = TrivArg + go (App fn (Type _)) n = go fn n + go (App fn (Coercion _)) n = go fn n go (App fn _) n = go fn (n+1) go (Note _ a) n = go a n go (Cast e _) n = go e n go (Lam v e) n - | isTyCoVar v = go e n + | isTyVar v = go e n | n>0 = go e (n-1) | otherwise = ValueArg go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg } @@ -1208,7 +1213,7 @@ exprIsConApp_maybe id_unf (Cast expr co) Nothing -> Nothing ; Just (dc, _dc_univ_args, dc_args) -> - let (_from_ty, to_ty) = coercionKind co + let Pair _from_ty to_ty = coercionKind co dc_tc = dataConTyCon dc in case splitTyConApp_maybe to_ty of { @@ -1228,41 +1233,28 @@ exprIsConApp_maybe id_unf (Cast expr co) dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc - dc_eqs :: [(Type,Type)] -- All equalities from the DataCon - dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++ - [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc] - - (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args - (co_args, val_args) = splitAtList dc_eqs rest1 + (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ stripTypeArgs ex_args) - - -- Cast the existential coercion arguments - cast_co (ty1, ty2) (Type co) - = Type $ mkSymCoercion (substTy theta ty1) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty2) - cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg) - new_co_args = zipWith cast_co dc_eqs co_args - + theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ map mkReflCo (stripTypeArgs ex_args)) + -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg in #ifdef DEBUG let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr _dc_univ_args, ppr ex_args, ppr val_args] in - ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) - ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) #endif - Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) + Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) }} exprIsConApp_maybe id_unf expr @@ -1301,7 +1293,7 @@ exprIsConApp_maybe id_unf expr ----------- beta (Lam v body) pairs (arg : args) - | isTypeArg arg + | isTyCoArg arg = beta body ((v,arg):pairs) args beta (Lam {}) _ _ -- Un-saturated, or not a type lambda @@ -1313,10 +1305,10 @@ exprIsConApp_maybe id_unf expr subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] - stripTypeArgs :: [CoreExpr] -> [Type] stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) [ty | Type ty <- args] + -- We really do want isTypeArg here, not isTyCoArg! \end{code} Note [Unfolding DFuns] diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 70e1db7e2a..a0a229f6c6 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -16,7 +16,7 @@ Utility functions on @Core@ syntax -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions - mkSCC, mkCoerce, mkCoerceI, + mkSCC, mkCoerce, bindNonRec, needsCaseBinding, mkAltExpr, mkPiType, mkPiTypes, @@ -45,7 +45,7 @@ module CoreUtils ( -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg, - dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat + dataConRepInstPat, dataConRepFSInstPat ) where #include "HsVersions.h" @@ -62,7 +62,6 @@ import DataCon import PrimOp import Id import IdInfo -import TcType ( isPredTy ) import Type import Coercion import TyCon @@ -73,6 +72,7 @@ import TysPrim import FastString import Maybes import Util +import Pair import Data.Word import Data.Bits \end{code} @@ -91,9 +91,10 @@ exprType :: CoreExpr -> Type -- really be said to have a type exprType (Var var) = idType var exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co exprType (Let _ body) = exprType body exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = snd (coercionKind co) +exprType (Cast _ co) = pSnd (coercionKind co) exprType (Note _ e) = exprType e exprType (Lam binder expr) = mkPiType binder (exprType expr) exprType e@(App _ _) @@ -110,7 +111,7 @@ coreAltType (_,bs,rhs) where ty = exprType rhs free_tvs = tyVarsOfType ty - bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs + bad_binder b = isTyVar b && b `elemVarSet` free_tvs coreAltsType :: [CoreAlt] -> Type -- ^ Returns the type of the first alternative, which should be the same as for all alternatives @@ -143,10 +144,10 @@ Various possibilities suggest themselves: we are doing here. It's not too expensive, I think. \begin{code} -mkPiType :: EvVar -> Type -> Type +mkPiType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or a forall type, depending -- on whether it is given a type variable or a term variable. -mkPiTypes :: [EvVar] -> Type -> Type +mkPiTypes :: [Var] -> Type -> Type -- ^ 'mkPiType' for multiple type or value arguments mkPiType v ty @@ -172,11 +173,11 @@ applyTypeToArgs e op_ty (Type ty : args) go [ty] args where go rev_tys (Type ty : args) = go (ty:rev_tys) args - go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args - where - op_ty' = applyTysD msg op_ty (reverse rev_tys) - msg = ptext (sLit "applyTypeToArgs") <+> - panic_msg e op_ty + go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args + where + op_ty' = applyTysD msg op_ty (reverse rev_tys) + msg = ptext (sLit "applyTypeToArgs") <+> + panic_msg e op_ty applyTypeToArgs e op_ty (_ : args) = case (splitFunTy_maybe op_ty) of @@ -194,25 +195,22 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty %************************************************************************ \begin{code} --- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions -mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr -mkCoerceI (IdCo _) e = e -mkCoerceI (ACo co) e = mkCoerce co e - --- | Wrap the given expression in the coercion safely, coalescing nested coercions +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions mkCoerce :: Coercion -> CoreExpr -> CoreExpr +mkCoerce co e | isReflCo co = e mkCoerce co (Cast expr co2) - = ASSERT(let { (from_ty, _to_ty) = coercionKind co; - (_from_ty2, to_ty2) = coercionKind co2} in - from_ty `coreEqType` to_ty2 ) - mkCoerce (mkTransCoercion co2 co) expr + = ASSERT(let { Pair from_ty _to_ty = coercionKind co; + Pair _from_ty2 to_ty2 = coercionKind co2} in + from_ty `eqType` to_ty2 ) + mkCoerce (mkTransCo co2 co) expr mkCoerce co expr - = let (from_ty, _to_ty) = coercionKind co in --- if to_ty `coreEqType` from_ty + = let Pair from_ty _to_ty = coercionKind co in +-- if to_ty `eqType` from_ty -- then expr -- else - WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) + WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) (Cast expr co) \end{code} @@ -415,7 +413,8 @@ discount. \begin{code} exprIsTrivial :: CoreExpr -> Bool exprIsTrivial (Var _) = True -- See Note [Variables are trivial] -exprIsTrivial (Type _) = True +exprIsTrivial (Type _) = True +exprIsTrivial (Coercion _) = True exprIsTrivial (Lit lit) = litIsTrivial lit exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e exprIsTrivial (Note _ e) = exprIsTrivial e -- See Note [SCCs are trivial] @@ -469,10 +468,11 @@ exprIsDupable e = isJust (go dupAppSize e) where go :: Int -> CoreExpr -> Maybe Int - go n (Type {}) = Just n - go n (Var {}) = decrement n - go n (Note _ e) = go n e - go n (Cast e _) = go n e + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Note _ e) = go n e + go n (Cast e _) = go n e go n (App f a) | Just n' <- go n a = go n' f go n (Lit lit) | litIsDupable lit = decrement n go _ _ = Nothing @@ -540,13 +540,14 @@ exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in type CheapAppFun = Id -> Int -> Bool exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool -exprIsCheap' _ (Lit _) = True -exprIsCheap' _ (Type _) = True -exprIsCheap' _ (Var _) = True -exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e -exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e -exprIsCheap' good_app (Lam x e) = isRuntimeVar x - || exprIsCheap' good_app e +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Coercion _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] @@ -684,8 +685,9 @@ it's applied only to dictionaries. -- We can only do this if the @y + 1@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception. exprOkForSpeculation :: CoreExpr -> Bool -exprOkForSpeculation (Lit _) = True -exprOkForSpeculation (Type _) = True +exprOkForSpeculation (Lit _) = True +exprOkForSpeculation (Type _) = True +exprOkForSpeculation (Coercion _) = True exprOkForSpeculation (Var v) | isTickBoxOp v = False -- Tick boxes are *not* suitable for speculation @@ -865,12 +867,14 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like -- we could get an infinite loop is_hnf_like (Lit _) = True - is_hnf_like (Type _) = True -- Types are honorary Values; + is_hnf_like (Type _) = True -- Types are honorary Values; -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e is_hnf_like (Note _ e) = is_hnf_like e is_hnf_like (Cast e _) = is_hnf_like e - is_hnf_like (App e (Type _)) = is_hnf_like e + is_hnf_like (App e (Type _)) = is_hnf_like e + is_hnf_like (App e (Coercion _)) = is_hnf_like e is_hnf_like (App e a) = app_is_value e [a] is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like _ = False @@ -896,36 +900,26 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like These InstPat functions go here to avoid circularity between DataCon and Id \begin{code} -dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id]) +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) -dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv"))) -dataConRepFSInstPat = dataConInstPat dataConRepArgTys -dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv"))) - where - dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc - -- Remember to include the existential dictionaries - -dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys - -> [FastString] -- A long enough list of FSs to use for names - -> [Unique] -- An equally long list of uniques, at least one for each binder - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [Id]) -- Return instantiated variables -- dataConInstPat arg_fun fss us con inst_tys returns a triple --- (ex_tvs, co_tvs, arg_ids), +-- (ex_tvs, arg_ids), -- -- ex_tvs are intended to be used as binders for existential type args -- --- co_tvs are intended to be used as binders for coercion args and the kinds --- of these vars have been instantiated by the inst_tys and the ex_tys --- The co_tvs include both GADT equalities (dcEqSpec) and --- programmer-specified equalities (dcEqTheta) --- -- arg_ids are indended to be used as binders for value arguments, -- and their types have been instantiated with inst_tys and ex_tys --- The arg_ids include both dicts (dcDictTheta) and --- programmer-specified arguments (after rep-ing) (deRepArgTys) +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) -- -- Example. -- The following constructor T1 @@ -940,29 +934,22 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys -- -- dataConInstPat fss us T1 (a1',b') will return -- --- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b'']) +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat arg_fun fss uniqs con inst_tys - = (ex_bndrs, co_bndrs, arg_ids) +dataConInstPat fss uniqs con inst_tys + = (ex_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con - arg_tys = arg_fun con - eq_spec = dataConEqSpec con - eq_theta = dataConEqTheta con - eq_preds = eqSpecPreds eq_spec ++ eq_theta + arg_tys = dataConRepArgTys con n_ex = length ex_tvs - n_co = length eq_preds -- split the Uniques and FastStrings - (ex_uniqs, uniqs') = splitAt n_ex uniqs - (co_uniqs, id_uniqs) = splitAt n_co uniqs' - - (ex_fss, fss') = splitAt n_ex fss - (co_fss, id_fss) = splitAt n_co fss' + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss -- Make existential type variables ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs @@ -974,17 +961,9 @@ dataConInstPat arg_fun fss uniqs con inst_tys -- Make the instantiating substitution subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) - -- Make new coercion vars, instantiating kind - co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds - mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind - where - new_name = mkSysTvName uniq fs - co_kind = substTy subst (mkPredTy eq_pred) - - -- make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan + -- Make value vars, instantiating types + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys - \end{code} %************************************************************************ @@ -1003,7 +982,8 @@ cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr (Var v1) (Var v2) = v1==v2 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 -cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2 +cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 +cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 @@ -1019,7 +999,8 @@ exprIsBig :: Expr b -> Bool -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' exprIsBig (Lit _) = False exprIsBig (Var _) = False -exprIsBig (Type _) = False +exprIsBig (Type _) = False +exprIsBig (Coercion _) = False exprIsBig (Lam _ e) = exprIsBig e exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! @@ -1061,14 +1042,15 @@ eqExprX id_unfolding_fun env e1 e2 , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2)) = go (nukeRnEnvR env) e1 e2' - go _ (Lit lit1) (Lit lit2) = lit1 == lit2 - go env (Type t1) (Type t2) = tcEqTypeX env t1 t2 - go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2 + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = eqTypeX env t1 t2 + go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2 go env (Lam b1 e1) (Lam b2 e2) - = tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination && go (rnBndr2 env b1 b2) e1 e2 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) @@ -1084,7 +1066,7 @@ eqExprX id_unfolding_fun env e1 e2 go env (Case e1 b1 _ a1) (Case e2 b2 _ a2) = go env e1 e2 - && tcEqTypeX env (idType b1) (idType b2) + && eqTypeX env (idType b1) (idType b2) && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 go _ _ _ = False @@ -1128,16 +1110,17 @@ exprSize (App f a) = exprSize f + exprSize a exprSize (Lam b e) = varSize b + exprSize e exprSize (Let b e) = bindSize b + exprSize e exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e exprSize (Note n e) = noteSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 noteSize :: Note -> Int noteSize (SCC cc) = cc `seq` 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int -varSize b | isTyCoVar b = 1 +varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` megaSeqIdInfo (idInfo b) `seq` 1 @@ -1187,30 +1170,23 @@ bndrStats v = oneTM `plusCS` tyStats (varType v) exprStats :: CoreExpr -> CoreStats exprStats (Var {}) = oneTM exprStats (Lit {}) = oneTM -exprStats (App f (Type t))= tyCoStats (exprType f) t +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c exprStats (App f a) = exprStats f `plusCS` exprStats a exprStats (Lam b e) = bndrStats b `plusCS` exprStats e exprStats (Let b e) = bindStats b `plusCS` exprStats e exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as exprStats (Cast e co) = coStats co `plusCS` exprStats e exprStats (Note _ e) = exprStats e -exprStats (Type ty) = zeroCS { cs_ty = typeSize ty } - -- Ugh (might be a co) altStats :: CoreAlt -> CoreStats altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r -tyCoStats :: Type -> Type -> CoreStats -tyCoStats fun_ty arg - = case splitForAllTy_maybe fun_ty of - Just (tv,_) | isCoVar tv -> coStats arg - _ -> tyStats arg - tyStats :: Type -> CoreStats tyStats ty = zeroCS { cs_ty = typeSize ty } coStats :: Coercion -> CoreStats -coStats co = zeroCS { cs_co = typeSize co } +coStats co = zeroCS { cs_co = coercionSize co } \end{code} %************************************************************************ @@ -1252,15 +1228,17 @@ hash_expr env (Lam b e) = hash_expr (extend_env env b) e hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1 -- Shouldn't happen. Better to use WARN than trace, because trace -- prevents the CPR optimisation kicking in for hash_expr. +hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1 fast_hash_expr :: HashEnv -> CoreExpr -> Word32 -fast_hash_expr env (Var v) = hashVar env v -fast_hash_expr env (Type t) = fast_hash_type env t -fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) -fast_hash_expr env (Cast e _) = fast_hash_expr env e -fast_hash_expr env (Note _ e) = fast_hash_expr env e -fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! -fast_hash_expr _ _ = 1 +fast_hash_expr env (Var v) = hashVar env v +fast_hash_expr env (Type t) = fast_hash_type env t +fast_hash_expr env (Coercion co) = fast_hash_co env co +fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) +fast_hash_expr env (Cast e _) = fast_hash_expr env e +fast_hash_expr env (Note _ e) = fast_hash_expr env e +fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! +fast_hash_expr _ _ = 1 fast_hash_type :: HashEnv -> Type -> Word32 fast_hash_type env ty @@ -1269,6 +1247,13 @@ fast_hash_type env ty in foldr (\t n -> fast_hash_type env t + n) hash_tc tys | otherwise = 1 +fast_hash_co :: HashEnv -> Coercion -> Word32 +fast_hash_co env co + | Just cv <- getCoVar_maybe co = hashVar env cv + | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc)) + in foldr (\c n -> fast_hash_co env c + n) hash_tc cos + | otherwise = 1 + extend_env :: HashEnv -> Var -> (Int, VarEnv Int) extend_env (n,env) b = (n+1, extendVarEnv env b n) @@ -1368,18 +1353,18 @@ need to address that here. \begin{code} tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body - = go (reverse bndrs) body (IdCo (exprType body)) + = go (reverse bndrs) body (mkReflCo (exprType body)) where incoming_arity = count isId bndrs go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr - -> CoercionI -- Of type tr ~ ts + -> Coercion -- Of type tr ~ ts -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion go [] fun co - | ok_fun fun = Just (mkCoerceI co fun) + | ok_fun fun = Just (mkCoerce co fun) go (b : bs) (App fun arg) co | Just co' <- ok_arg b arg co @@ -1390,7 +1375,7 @@ tryEtaReduce bndrs body --------------- -- Note [Eta reduction conditions] ok_fun (App fun (Type ty)) - | not (any (`elemVarSet` tyVarsOfType ty) bndrs) + | not (any (`elemVarSet` tyVarsOfType ty) bndrs) = ok_fun fun ok_fun (Var fun_id) = not (fun_id `elem` bndrs) @@ -1406,22 +1391,22 @@ tryEtaReduce bndrs body | otherwise = idArity fun --------------- - ok_lam v = isTyCoVar v || isDictId v + ok_lam v = isTyVar v || isEvVar v --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> CoercionI -- Of kind (t1~t2) - -> Maybe CoercionI -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (and similarly for tyvars, coercion args) + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Maybe Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) -- See Note [Eta reduction with casted arguments] ok_arg bndr (Type ty) co | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkForAllTyCoI tv co) + , bndr == tv = Just (mkForAllCo tv co) ok_arg bndr (Var v) co - | bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co) + | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co) ok_arg bndr (Cast (Var v) co_arg) co - | bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co) + | bndr == v = Just (mkFunCo (mkSymCo co_arg) co) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg _ _ _ = Nothing diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index 07a1dfbd8e..359419ca06 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -4,7 +4,6 @@ \begin{code} module ExternalCore where - data Module = Module Mname [Tdef] [Vdefg] @@ -51,21 +50,21 @@ data Alt type Vbind = (Var,Ty) type Tbind = (Tvar,Kind) +-- Internally, we represent types and coercions separately; but for +-- the purposes of external core (at least for now) it's still +-- convenient to collapse them into a single type. data Ty = Tvar Tvar | Tcon (Qual Tcon) | Tapp Ty Ty | Tforall Tbind Ty --- We distinguish primitive coercions --- (represented in GHC by wired-in names), because --- External Core treats them specially, so we have --- to print them out with special syntax. +-- We distinguish primitive coercions because External Core treats +-- them specially, so we have to print them out with special syntax. | TransCoercion Ty Ty | SymCoercion Ty | UnsafeCoercion Ty Ty | InstCoercion Ty Ty - | LeftCoercion Ty - | RightCoercion Ty + | NthCoercion Int Ty data Kind = Klifted diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index f1d42738a2..b6bc7d4b37 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -45,8 +45,7 @@ module MkCore ( #include "HsVersions.h" import Id -import IdInfo -import Var ( EvVar, mkWildCoVar, setTyVarUnique ) +import Var ( EvVar, setTyVarUnique ) import CoreSyn import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) @@ -58,8 +57,10 @@ import PrelNames import TcType ( mkSigmaTy ) import Type +import Coercion import TysPrim import DataCon ( DataCon, dataConWorkId ) +import IdInfo ( vanillaIdInfo, setStrictnessInfo, setArityInfo ) import Demand import Name import Outputable @@ -102,6 +103,7 @@ mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr -- Check the invariant that the arg of an App is ok-for-speculation if unlifted -- See CoreSyn Note [CoreSyn let/app invariant] mkCoreApp fun (Type ty) = App fun (Type ty) +mkCoreApp fun (Coercion co) = App fun (Coercion co) mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg ) mk_val_app fun arg arg_ty res_ty where @@ -117,6 +119,7 @@ mkCoreApps orig_fun orig_args where go fun _ [] = fun go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args ) go (mk_val_app fun arg arg_ty res_ty) res_ty args where @@ -148,8 +151,7 @@ mk_val_app fun arg arg_ty res_ty -- fragmet of it as the fun part of a 'mk_val_app'. mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred@(EqPred {}) = mkWildCoVar (mkPredTy pred) -mkWildEvBinder pred = mkWildValBinder (mkPredTy pred) +mkWildEvBinder pred = mkWildValBinder (mkPredTy pred) -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index cb784e8ab4..01655048f9 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -13,6 +13,8 @@ import Module import CoreSyn import HscTypes import TyCon +import Class +import TysPrim( eqPredPrimTyCon ) import TypeRep import Type import PprExternalCore () -- Instances @@ -78,10 +80,7 @@ collect_tdefs tcon tdefs where tdef | isNewTyCon tcon = C.Newtype (qtc tcon) - (case newTyConCo_maybe tcon of - Just co -> qtc co - Nothing -> pprPanic ("MkExternalCore: newtype tcon\ - should have a coercion: ") (ppr tcon)) + (qcc (newTyConCo tcon)) (map make_tbind tyvars) (make_ty (snd (newTyConRhs tcon))) | otherwise = @@ -94,6 +93,8 @@ collect_tdefs _ tdefs = tdefs qtc :: TyCon -> C.Qual C.Tcon qtc = make_con_qid . tyConName +qcc :: CoAxiom -> C.Qual C.Tcon +qcc = make_con_qid . co_ax_name make_cdef :: DataCon -> C.Cdef make_cdef dcon = C.Constr dcon_name existentials tys @@ -142,15 +143,16 @@ make_exp (Var v) = do make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s) make_exp (Lit l) = return $ C.Lit (make_lit l) make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t)) +make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO make_exp (App e1 e2) = do rator <- make_exp e1 rand <- make_exp e2 return $ C.App rator rand -make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b -> +make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> return $ C.Lam (C.Tb (make_tbind v)) b) make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> return $ C.Lam (C.Vb (make_vbind v)) b) -make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co)) +make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co)) make_exp (Let b e) = do vd <- make_vdef False b body <- make_exp e @@ -170,7 +172,7 @@ make_alt (DataAlt dcon, vs, e) = do (map make_tbind tbs) (map make_vbind vbs) newE - where (tbs,vbs) = span isTyCoVar vs + where (tbs,vbs) = span isTyVar vs make_alt (LitAlt l,_,e) = make_exp e >>= (return . (C.Alit (make_lit l))) make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault) -- This should never happen, as the DEFAULT alternative binds no variables, @@ -229,29 +231,12 @@ make_ty' (TyConApp tc ts) = make_tyConApp tc ts make_ty' (PredTy p) = make_ty (predTypeRep p) make_tyConApp :: TyCon -> [Type] -> C.Ty -make_tyConApp tc [t1, t2] | tc == transCoercionTyCon = - C.TransCoercion (make_ty t1) (make_ty t2) -make_tyConApp tc [t] | tc == symCoercionTyCon = - C.SymCoercion (make_ty t) -make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon = - C.UnsafeCoercion (make_ty t1) (make_ty t2) -make_tyConApp tc [t] | tc == leftCoercionTyCon = - C.LeftCoercion (make_ty t) -make_tyConApp tc [t] | tc == rightCoercionTyCon = - C.RightCoercion (make_ty t) -make_tyConApp tc [t1, t2] | tc == instCoercionTyCon = - C.InstCoercion (make_ty t1) (make_ty t2) --- this fails silently if we have an application --- of a wired-in coercion tycon to the wrong number of args. --- Not great... make_tyConApp tc ts = foldl C.Tapp (C.Tcon (qtc tc)) (map make_ty ts) - make_kind :: Kind -> C.Kind -make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2) - where (t1, t2) = getEqPredTys p +make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2) make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) make_kind k | isLiftedTypeKind k = C.Klifted @@ -299,6 +284,28 @@ make_var_qid force_unqual = make_qid force_unqual True make_con_qid :: Name -> C.Qual C.Id make_con_qid = make_qid False False +make_co :: Coercion -> C.Ty +make_co (Refl ty) = make_ty ty +make_co (TyConAppCo tc cos) = make_conAppCo (qtc tc) cos +make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2) +make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co) +make_co (PredCo (ClassP cls cos)) = make_conAppCo (qtc (classTyCon cls)) cos +make_co (PredCo (IParam _ co)) = make_co co +make_co (PredCo (EqPred co1 co2)) = make_conAppCo (qtc eqPredPrimTyCon) [co1,co2] +make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv)) +make_co (AxiomInstCo cc cos) = make_conAppCo (qcc cc) cos +make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2) +make_co (SymCo co) = C.SymCoercion (make_co co) +make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2) +make_co (NthCo d co) = C.NthCoercion d (make_co co) +make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty) + +-- Used for both tycon app coercions and axiom instantiations. +make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty +make_conAppCo con cos = + foldl C.Tapp (C.Tcon con) + (map make_co cos) + ------- isALocal :: Name -> CoreM Bool isALocal vName = do diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 041b842b81..e9452dcb73 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -106,7 +106,9 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd + +ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) ppr_expr _ (Var name) = ppr name ppr_expr _ (Lit lit) = ppr lit @@ -255,8 +257,8 @@ pprArg :: OutputableBndr a => Expr a -> SDoc pprArg (Type ty) | opt_SuppressTypeApplications = empty | otherwise = ptext (sLit "@") <+> pprParendType ty - -pprArg expr = pprParendExpr expr +pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co +pprArg expr = pprParendExpr expr \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ @@ -268,7 +270,7 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder - | isTyCoVar binder = pprKindedTyVarBndr binder + | isTyVar binder = pprKindedTyVarBndr binder | otherwise = pprTypedBinder binder $$ ppIdInfo binder (idInfo binder) @@ -279,7 +281,7 @@ pprCoreBinder bind_site bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder - | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind + | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc @@ -287,7 +289,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc pprTypedLCBinder bind_site debug_on var | not debug_on && isDeadBinder var = char '_' | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info - | isTyCoVar var = parens (pprKindedTyVarBndr var) + | isTyVar var = parens (pprKindedTyVarBndr var) | otherwise = parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) where @@ -298,7 +300,7 @@ pprTypedLCBinder bind_site debug_on var pprTypedBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedBinder binder - | isTyCoVar binder = pprKindedTyVarBndr binder + | isTyVar binder = pprKindedTyVarBndr binder | opt_SuppressTypeSignatures = empty | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index 3c4b25e420..5303b0d1b6 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -106,10 +106,8 @@ pty (SymCoercion t) = sep [text "%sym", paty t] pty (UnsafeCoercion t1 t2) = sep [text "%unsafe", paty t1, paty t2] -pty (LeftCoercion t) = - sep [text "%left", paty t] -pty (RightCoercion t) = - sep [text "%right", paty t] +pty (NthCoercion n t) = + sep [text "%nth", int n, paty t] pty (InstCoercion t1 t2) = sep [text "%inst", paty t1, paty t2] pty t = pbty t diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 2432051c7b..bcbf4435eb 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -27,7 +27,6 @@ import TysWiredIn import PrelNames import TyCon import Type -import Unify( dataConCannotMatch ) import SrcLoc import UniqSet import Util diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 37a3cf9236..7b008e9aaf 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -378,6 +378,8 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList. That keeps the desugaring of list comprehensions simple too. + + Nor do we want to warn of conversion identities on the LHS; the rule is precisly to optimise them: {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 815c0d1cfb..85883dc05f 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s). \begin{code} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, + dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, DsEvBind(..), AutoScc(..) ) where @@ -36,6 +36,7 @@ import Digraph import TcType import Type +import Coercion import TysPrim ( anyTypeOfKind ) import CostCentre import Module @@ -230,8 +231,8 @@ dsEvBinds bs = return (map dsEvGroup sccs) free_vars_of :: EvTerm -> [EvVar] free_vars_of (EvId v) = [v] - free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) - free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) + free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co) + free_vars_of (EvCoercion co) = varSetElems (tyCoVarsOfCo co) free_vars_of (EvDFunApp _ _ vs) = vs free_vars_of (EvSuperClass d _) = [d] @@ -247,7 +248,7 @@ dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n))) (arg_tys, _) = splitFunTys rho bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..]) ++ map mkWildValBinder arg_tys - mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var)) + mk_wild_pred (p, i) | i==n = ASSERT( p `eqPred` (coVarPred co_var)) co_var | otherwise = mkWildEvBinder p @@ -263,7 +264,7 @@ dsEvTerm :: EvTerm -> CoreExpr dsEvTerm (EvId v) = Var v dsEvTerm (EvCast v co) = Cast (Var v) co dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = Type co +dsEvTerm (EvCoercion co) = Coercion co dsEvTerm (EvSuperClass d n) = ASSERT( isClassPred (classSCTheta cls !! n) ) -- We can only select *dictionary* superclasses @@ -601,13 +602,9 @@ decomposeRuleLhs bndrs lhs <+> ptext (sLit "is not bound in RULE lhs")) 2 (ppr opt_lhs) pp_bndr bndr - | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr - | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr - | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr) + | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr + | isEvVar bndr = ptext (sLit "constraint") <+> ppr bndr <+> dcolon <+> ppr (evVarPred bndr) | otherwise = ptext (sLit "variable") <+> ppr bndr - - get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" - (tcSplitPredTy_maybe (idType b)) \end{code} Note [Simplifying the left-hand side of a RULE] @@ -634,7 +631,6 @@ otherwise we don't match when given an argument like NB: tcSimplifyRuleLhs is very careful not to generate complicated dictionary expressions that we might have to match - Note [Matching seqId] ~~~~~~~~~~~~~~~~~~~ The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index f46d99e504..58ebc26b2b 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -273,7 +273,7 @@ boxResult result_ty ; let io_data_con = head (tyConDataCons io_tycon) toIOCon = dataConWrapId io_data_con - wrap the_call = mkCoerceI (mkSymCoI co) $ + wrap the_call = mkCoerce (mkSymCo co) $ mkApps (Var toIOCon) [ Type io_res_ty, Lam state_id $ @@ -372,7 +372,7 @@ resultWrapper result_ty -- Recursive newtypes | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty = do (maybe_ty, wrapper) <- resultWrapper rep_ty - return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e)) + return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e)) -- The type might contain foralls (eg. for dummy type arguments, -- referring to 'Ptr a' is legal). diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 1781aef5f8..5db2175a50 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -49,8 +49,8 @@ import DynFlags import StaticFlags import CostCentre import Id -import Var import VarSet +import VarEnv import DataCon import TysWiredIn import BasicTypes @@ -527,12 +527,12 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, arg_tys, _) = dataConFullSig con + theta, arg_tys, _) = dataConFullSig con subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta)) + ; theta_vars <- mapM newPredVarDs (substTheta subst theta) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids @@ -543,21 +543,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) wrap = mkWpEvVarApps theta_vars `WpCompose` mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys - , isNothing (lookupTyVar wrap_subst tv) ] + , not (tv `elemVarEnv` wrap_subst) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast -- Note [Update for GADTs] wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (WpCast wrap_co) rhs - wrap_co = mkTyConApp tycon [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys] - lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of - Just ty' -> ty' - Nothing -> ty - wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var)) - | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] - + wrap_co = mkTyConAppCo tycon [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys] + lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkReflCo ty + wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var)) + | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds @@ -597,7 +597,7 @@ dsExpr (HsTick ix vars e) = do dsExpr (HsBinTick ixT ixF e) = do e2 <- dsLExpr e - do { ASSERT(exprType e2 `coreEqType` boolTy) + do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } \end{code} @@ -904,7 +904,7 @@ warnAboutIdentities (Var v) co_fn | idName v `elem` conversionNames , let fun_ty = exprType (co_fn (Var v)) , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty - , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty + , arg_ty `eqType` res_ty -- So we are converting ty -> ty = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty , nest 2 $ ptext (sLit "can probably be omitted") , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) @@ -931,14 +931,14 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () warnDiscardedDoBindings rhs container_ty returning_ty = do { -- Warn about discarding non-() things in 'monadic' binding ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `tcEqType` unitTy) + ; if warn_unused && not (returning_ty `eqType` unitTy) then warnDs (unusedMonadBind rhs returning_ty) else do { -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind ; warn_wrong <- doptDs Opt_WarnWrongDoBind ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ + Just (returning_container_ty, _) -> when (warn_wrong && container_ty `eqType` returning_container_ty) $ warnDs (wrongMonadBind rhs returning_ty) _ -> return () } } diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 4d0a148e15..b391b8f02a 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -28,7 +28,6 @@ import Type import TyCon import Coercion import TcType -import Var import CmmExpr import CmmUtils @@ -140,7 +139,7 @@ dsCImport id (CLabel cid) cconv _ = do IsFunction _ -> IsData (resTy, foRhs) <- resultWrapper ty - ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this + ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this let rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) stdcall_info = fun_type_arg_stdcall_info cconv ty @@ -382,9 +381,9 @@ dsFExportDynamic id cconv = do ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback - let io_app = mkLams tvs $ - Lam cback $ - mkCoerceI (mkSymCoI co) $ + let io_app = mkLams tvs $ + Lam cback $ + mkCoerce (mkSymCo co) $ mkApps (Var bindIOId) [ Type stable_ptr_ty , Type res_ty @@ -483,7 +482,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc typeCmmType (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes cResType | res_hty_is_unit = text "void" | otherwise = showStgType res_hty @@ -675,7 +674,7 @@ getPrimTyOf ty -- e.g. 'W' is a signed 32-bit integer. primTyDescChar :: Type -> Char primTyDescChar ty - | ty `coreEqType` unitTy = 'v' + | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep (getPrimTyOf ty) of IntRep -> signed_word diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 3a976878e3..8b5a26894f 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -53,7 +53,6 @@ import CoreUtils import MkCore import MkId import Id -import Var import Name import Literal import TyCon @@ -75,7 +74,6 @@ import StaticFlags \end{code} - %************************************************************************ %* * Rebindable syntax @@ -256,10 +254,9 @@ wrapBinds [] e = e wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- Can deal with term variables *or* type variables - | new==old = body - | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body - | otherwise = Let (NonRec new (Var old)) body +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = Case (Var var) var (exprType body) @@ -605,7 +602,7 @@ mkSelectorBinds pat val_expr return (bndr_var, rhs_expr) where error_expr = mkCoerce co (Var err_var) - co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var) + co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var) is_simple_lpat p = is_simple_pat (unLoc p) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 5c6b224466..00a162e4df 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -29,6 +29,7 @@ import DataCon import MatchCon import MatchLit import Type +import Coercion import TysWiredIn import ListSetOps import SrcLoc @@ -825,7 +826,7 @@ sameGroup (PgCon _) (PgCon _) = True -- One case expression sameGroup (PgLit _) (PgLit _) = True -- One case expression sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] -sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 -- CoPats are in the same goup only if the type of the -- enclosed pattern is the same. The patterns outside the CoPat -- always have the same type, so this boils down to saying that @@ -873,7 +874,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- which resolve the overloading (e.g., fromInteger 1), -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) - tcEqType (overLitType l) (overLitType l') && l == l' + eqType (overLitType l) (overLitType l') && l == l' exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? @@ -897,7 +898,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- tup_arg (Present e1) (Present e2) = lexp e1 e2 - tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2 + tup_arg (Missing t1) (Missing t2) = eqType t1 t2 tup_arg _ _ = False --------- @@ -910,9 +911,9 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpCast c) (WpCast c') = tcEqType c c' + wrap (WpCast c) (WpCast c') = coreEqCoercion c c' wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2 - wrap (WpTyApp t) (WpTyApp t') = tcEqType t t' + wrap (WpTyApp t) (WpTyApp t') = eqType t t' -- Enhancement: could implement equality for more wrappers -- if it seems useful (lams and lets) wrap _ _ = False @@ -920,7 +921,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- ev_term :: EvTerm -> EvTerm -> Bool ev_term (EvId a) (EvId b) = a==b - ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b + ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b ev_term _ _ = False --------- @@ -959,3 +960,4 @@ If the first arg matches '1' but the second does not match 'True', we cannot jump to the third equation! Because the same argument might match '2'! Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. + diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 03fa325651..d84b9013cc 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -28,7 +28,6 @@ import DsUtils import Util ( all2, takeList, zipEqual ) import ListSetOps ( runs ) import Id -import Var ( Var ) import NameEnv import SrcLoc import Outputable diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index c509eb6255..b3b4069f80 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -424,6 +424,7 @@ Library Generics InstEnv TyCon + Kind Type TypeRep Unify @@ -450,6 +451,7 @@ Library MonadUtils OrdList Outputable + Pair Panic Pretty Serialized diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index f34ac9c172..8e90d7d578 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -30,10 +30,7 @@ import CoreFVs import Type import DataCon import TyCon --- import Type import Util --- import DataCon -import Var import VarSet import TysPrim import DynFlags @@ -253,7 +250,7 @@ schemeR fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' - $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs $$ pprCoreExpr (deAnnotate rhs) $$ char ' ' ))) False @@ -838,7 +835,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple rhs_code <- schemeE (d_alts+size) s p' rhs return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code) where - real_bndrs = filter (not.isTyCoVar) bndrs + real_bndrs = filterOut isTyVar bndrs my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) @@ -1460,7 +1457,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) -- whereas value lambdas cannot; that is why they are nuked here bcView (AnnNote _ (_,e)) = Just e bcView (AnnCast (_,e) _) = Just e -bcView (AnnLam v (_,e)) | isTyCoVar v = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e bcView (AnnApp (_,e) (_, AnnType _)) = Just e bcView _ = Nothing diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 59f5669e3e..050d680d6c 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -448,7 +448,7 @@ cPprTermBase y = --Note pprinting of list terms is not lazy doList p (Term{subTerms=[h,t]}) = do let elems = h : getListTerms t - isConsLast = not(termType(last elems) `coreEqType` termType h) + isConsLast = not(termType(last elems) `eqType` termType h) print_elems <- mapM (y cons_prec) elems return$ if isConsLast then cparen (p >= cons_prec) @@ -879,8 +879,8 @@ improveRTTIType _ base_ty new_ty myDataConInstArgTys :: DataCon -> [Type] -> [Type] myDataConInstArgTys dc args - | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args - | otherwise = dataConRepArgTys dc + | isVanillaDataCon dc = dataConInstArgTys dc args + | otherwise = dataConRepArgTys dc mydataConType :: DataCon -> QuantifiedType -- ^ Custom version of DataCon.dataConUserType where we diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e080bee8cf..11d1dcb080 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -357,7 +357,7 @@ data IPBind id instance (OutputableBndr id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ifPprDebug (ppr ds) + $$ ifPprDebug (ppr ds) instance (OutputableBndr id) => Outputable (IPBind id) where ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) @@ -457,7 +457,7 @@ data EvTerm deriving( Data, Typeable) evVarTerm :: EvVar -> EvTerm -evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v) +evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v) | otherwise = EvId v \end{code} @@ -546,7 +546,7 @@ pprHsWrapper doc wrap help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") - <+> pprParendType co)] + <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] @@ -572,8 +572,8 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co - ppr (EvCoercion co) = ppr co + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 78b5887a59..740bfa7172 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -24,7 +24,7 @@ module HsPat ( isBangHsBind, isLiftedPatBind, isBangLPat, hsPatNeedsParens, - isIrrefutableHsPat, + isIrrefutableHsPat, pprParendLPat ) where @@ -65,7 +65,7 @@ data Pat id -- support hsPatType :: Pat Id -> Type | VarPat id -- Variable - | LazyPat (LPat id) -- Lazy pattern + | LazyPat (LPat id) -- Lazy pattern | AsPat (Located id) (LPat id) -- As pattern | ParPat (LPat id) -- Parenthesised pattern | BangPat (LPat id) -- Bang pattern diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 13f3cd7e55..3316634e87 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -19,9 +19,9 @@ module HsUtils( mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsLams, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, + coToHsWrapper, mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCo, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -77,7 +77,7 @@ import HsLit import RdrName import Var import Coercion -import Type +import TypeRep import DataCon import Name import NameSet @@ -137,25 +137,25 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e -mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id -mkHsWrapCoI (IdCo _) e = e -mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e +mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id +mkHsWrapCo (Refl _) e = e +mkHsWrapCo co e = mkHsWrap (WpCast co) e -mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id -mkLHsWrapCoI (IdCo _) e = e -mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e) +mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo (Refl _) e = e +mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e) -coiToHsWrapper :: CoercionI -> HsWrapper -coiToHsWrapper (IdCo _) = idHsWrapper -coiToHsWrapper (ACo co) = WpCast co +coToHsWrapper :: Coercion -> HsWrapper +coToHsWrapper (Refl _) = idHsWrapper +coToHsWrapper co = WpCast co mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty -mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id -mkHsWrapPatCoI (IdCo _) pat _ = pat -mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty +mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo (Refl _) pat _ = pat +mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index b1c97cdf00..134dcfac2c 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,4 +1,3 @@ - {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -903,10 +902,11 @@ instance Binary IfaceType where put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases - put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys } put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys } + put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys } + get bh = do h <- getByte bh case h of @@ -939,11 +939,11 @@ instance Binary IfaceType where 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } - _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) } instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 put_ bh IfaceBoolTc = putByte bh 2 put_ bh IfaceCharTc = putByte bh 3 @@ -954,9 +954,9 @@ instance Binary IfaceTyCon where put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 put_ bh IfaceUbxTupleKindTc = putByte bh 9 put_ bh IfaceArgTypeKindTc = putByte bh 10 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } - put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } - put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } + put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } + put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } get bh = do h <- getByte bh @@ -973,7 +973,27 @@ instance Binary IfaceTyCon where 10 -> return IfaceArgTypeKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } 12 -> do { ext <- get bh; return (IfaceTc ext) } - _ -> do { k <- get bh; return (IfaceAnyTc k) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } + +instance Binary IfaceCoCon where + put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } + put_ bh IfaceReflCo = putByte bh 1 + put_ bh IfaceUnsafeCo = putByte bh 2 + put_ bh IfaceSymCo = putByte bh 3 + put_ bh IfaceTransCo = putByte bh 4 + put_ bh IfaceInstCo = putByte bh 5 + put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceCoAx n) } + 1 -> return IfaceReflCo + 2 -> return IfaceUnsafeCo + 3 -> return IfaceSymCo + 4 -> return IfaceTransCo + 5 -> return IfaceInstCo + _ -> do { d <- get bh; return (IfaceNthCo d) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -1013,50 +1033,50 @@ instance Binary IfaceExpr where put_ bh (IfaceType ab) = do putByte bh 1 put_ bh ab - put_ bh (IfaceTuple ac ad) = do + put_ bh (IfaceCo ab) = do putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 put_ bh ac put_ bh ad put_ bh (IfaceLam ae af) = do - putByte bh 3 + putByte bh 4 put_ bh ae put_ bh af put_ bh (IfaceApp ag ah) = do - putByte bh 4 + putByte bh 5 put_ bh ag put_ bh ah --- gaw 2004 - put_ bh (IfaceCase ai aj al ak) = do - putByte bh 5 + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 put_ bh ai put_ bh aj --- gaw 2004 - put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do - putByte bh 6 + putByte bh 7 put_ bh al put_ bh am put_ bh (IfaceNote an ao) = do - putByte bh 7 + putByte bh 8 put_ bh an put_ bh ao put_ bh (IfaceLit ap) = do - putByte bh 8 + putByte bh 9 put_ bh ap put_ bh (IfaceFCall as at) = do - putByte bh 9 + putByte bh 10 put_ bh as put_ bh at put_ bh (IfaceExt aa) = do - putByte bh 10 + putByte bh 11 put_ bh aa put_ bh (IfaceCast ie ico) = do - putByte bh 11 + putByte bh 12 put_ bh ie put_ bh ico put_ bh (IfaceTick m ix) = do - putByte bh 12 + putByte bh 13 put_ bh m put_ bh ix get bh = do @@ -1066,39 +1086,38 @@ instance Binary IfaceExpr where return (IfaceLcl aa) 1 -> do ab <- get bh return (IfaceType ab) - 2 -> do ac <- get bh + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh ad <- get bh return (IfaceTuple ac ad) - 3 -> do ae <- get bh + 4 -> do ae <- get bh af <- get bh return (IfaceLam ae af) - 4 -> do ag <- get bh + 5 -> do ag <- get bh ah <- get bh return (IfaceApp ag ah) - 5 -> do ai <- get bh + 6 -> do ai <- get bh aj <- get bh --- gaw 2004 - al <- get bh ak <- get bh --- gaw 2004 - return (IfaceCase ai aj al ak) - 6 -> do al <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh am <- get bh return (IfaceLet al am) - 7 -> do an <- get bh + 8 -> do an <- get bh ao <- get bh return (IfaceNote an ao) - 8 -> do ap <- get bh + 9 -> do ap <- get bh return (IfaceLit ap) - 9 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 10 -> do aa <- get bh + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh return (IfaceExt aa) - 11 -> do ie <- get bh + 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) - 12 -> do m <- get bh + 13 -> do m <- get bh ix <- get bh return (IfaceTick m ix) _ -> panic ("get IfaceExpr " ++ show h) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index e71eefe339..d30352cfa1 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -100,8 +100,8 @@ mkFamInstParentInfo :: Name -> [TyVar] mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon = do { -- Create the coercion ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc - ; let co_tycon = mkFamInstCoercion co_tycon_name tvs - family instTys rep_tycon + ; let co_tycon = mkFamInstCo co_tycon_name tvs + family instTys rep_tycon ; return $ FamInstTyCon family instTys co_tycon } ------------------------------------------------------ @@ -127,23 +127,15 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs -- because the latter is part of a knot, whereas the former is not. mkNewTyConRhs tycon_name tycon con = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs - cocon_maybe | all_coercions || isRecursiveTyCon tycon - = Just co_tycon - | otherwise - = Nothing - ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe) + ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon) ; return (NewTyCon { data_con = con, nt_rhs = rhs_ty, nt_etad_rhs = (etad_tvs, etad_rhs), - nt_co = cocon_maybe } ) } + nt_co = co_tycon } ) } -- Coreview looks through newtypes with a Nothing -- for nt_co, or uses explicit coercions otherwise where - -- If all_coercions is True then we use coercions for all newtypes - -- otherwise we use coercions for recursive newtypes and look through - -- non-recursive newtypes - all_coercions = True tvs = tyConTyVars tycon inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs) rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty @@ -156,7 +148,7 @@ mkNewTyConRhs tycon_name tycon con -- has a single argument (Foo a) that is a *type class*, so -- dataConInstOrigArgTys returns []. - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can etad_rhs :: Type -- return a TyCon without pulling on rhs_ty -- See Note [Tricky iface loop] in LoadIface (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 3eae7a3d41..48bef49f1e 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -234,10 +234,11 @@ data IfaceExpr = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] + | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion @@ -597,6 +598,7 @@ pprIfaceExpr _ (IfaceLit l) = ppr l pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) @@ -609,14 +611,14 @@ pprIfaceExpr add_par e@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) - = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [ptext (sLit "case") <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) - = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [ptext (sLit "case") <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) @@ -788,6 +790,8 @@ freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceCoConApp tc ts) = + freeNamesIfCo tc &&& fnList freeNamesIfType ts freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet freeNamesIfTvBndrs = fnList freeNamesIfTvBndr @@ -830,16 +834,16 @@ freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfType co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r -freeNamesIfExpr (IfaceCase s _ ty alts) +freeNamesIfExpr (IfaceCase s _ alts) = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - &&& freeNamesIfType ty where fn_alt (_con,_bs,r) = freeNamesIfExpr r @@ -865,6 +869,10 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfTc _ = emptyNameSet +freeNamesIfCo :: IfaceCoCon -> NameSet +freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc +freeNamesIfCo _ = emptyNameSet + freeNamesIfRule :: IfaceRule -> NameSet freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f , ifRuleArgs = es, ifRuleRhs = rhs }) diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index c97e16eef2..2f70e82b56 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -9,15 +9,18 @@ This module defines interface types and binders module IfaceType ( IfExtName, IfLclName, - IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), + IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, ifaceTyConName, -- Conversion from Type -> IfaceType - toIfaceType, toIfacePred, toIfaceContext, + toIfaceType, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, + -- Conversion from Coercion -> IfaceType + coToIfaceType, + -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, @@ -25,11 +28,13 @@ module IfaceType ( ) where -import TypeRep +import Coercion +import TypeRep hiding( maybeParen ) import TyCon import Id import Var import TysWiredIn +import TysPrim import Name import BasicTypes import Outputable @@ -59,14 +64,15 @@ type IfaceTvBndr = (IfLclName, IfaceKind) type IfaceKind = IfaceType type IfaceCoercion = IfaceType -data IfaceType - = IfaceTyVar IfLclName -- Type variable only, not tycon +data IfaceType -- A kind of universal type, used for types, kinds, and coercions + = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceAppTy IfaceType IfaceType + | IfaceFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType | IfacePredTy IfacePredType - | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceFunTy IfaceType IfaceType + | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated data IfacePredType -- NewTypes are handled as ordinary TyConApps = IfaceClassP IfExtName [IfaceType] @@ -75,18 +81,28 @@ data IfacePredType -- NewTypes are handled as ordinary TyConApps type IfaceContext = [IfacePredType] -data IfaceTyCon -- Abbreviations for common tycons with known names +data IfaceTyCon -- Encodes type consructors, kind constructors + -- coercion constructors, the lot = IfaceTc IfExtName -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim) -- other than 'Any :: *' itself + + -- Kind constructors | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc | IfaceUbxTupleKindTc | IfaceArgTypeKindTc -ifaceTyConName :: IfaceTyCon -> IfExtName -ifaceTyConName IfaceIntTc = intTyConName + -- Coercion constructors +data IfaceCoCon + = IfaceCoAx IfExtName + | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo + | IfaceTransCo | IfaceInstCo + | IfaceNthCo Int + +ifaceTyConName :: IfaceTyCon -> Name +ifaceTyConName IfaceIntTc = intTyConName ifaceTyConName IfaceBoolTc = boolTyConName ifaceTyConName IfaceCharTc = charTyConName ifaceTyConName IfaceListTc = listTyConName @@ -208,6 +224,10 @@ ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys ppr_ty _ (IfacePredTy st) = ppr st +ppr_ty ctxt_prec (IfaceCoConApp tc tys) + = maybeParen ctxt_prec tYCON_PREC + (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) + -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. @@ -268,6 +288,15 @@ instance Outputable IfaceTyCon where -- so we fake it. It's only for debug printing! ppr other_tc = ppr (ifaceTyConName other_tc) +instance Outputable IfaceCoCon where + ppr (IfaceCoAx n) = ppr n + ppr IfaceReflCo = ptext (sLit "Refl") + ppr IfaceUnsafeCo = ptext (sLit "Unsafe") + ppr IfaceSymCo = ptext (sLit "Sym") + ppr IfaceTransCo = ptext (sLit "Trans") + ppr IfaceInstCo = ptext (sLit "Inst") + ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d + ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -309,18 +338,15 @@ toIfaceKind = toIfaceType --------------------- toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type -toIfaceType (TyVarTy tv) = - IfaceTyVar (occNameFS (getOccName tv)) -toIfaceType (AppTy t1 t2) = - IfaceAppTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (FunTy t1 t2) = - IfaceFunTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (TyConApp tc tys) = - IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) -toIfaceType (ForAllTy tv t) = - IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) -toIfaceType (PredTy st) = - IfacePredTy (toIfacePred st) +toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyCoVar tv) +toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) +toIfaceType (PredTy st) = IfacePredTy (toIfacePred toIfaceType st) + +toIfaceTyCoVar :: TyCoVar -> FastString +toIfaceTyCoVar = occNameFS . getOccName ---------------- -- A little bit of (perhaps optional) trickiness here. When @@ -364,16 +390,40 @@ toIfaceTypes :: [Type] -> [IfaceType] toIfaceTypes ts = map toIfaceType ts ---------------- -toIfacePred :: PredType -> IfacePredType -toIfacePred (ClassP cls ts) = - IfaceClassP (getName cls) (toIfaceTypes ts) -toIfacePred (IParam ip t) = - IfaceIParam (mapIPName getOccName ip) (toIfaceType t) -toIfacePred (EqPred ty1 ty2) = - IfaceEqPred (toIfaceType ty1) (toIfaceType ty2) +toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType +toIfacePred to (ClassP cls ts) = IfaceClassP (getName cls) (map to ts) +toIfacePred to (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (to t) +toIfacePred to (EqPred ty1 ty2) = IfaceEqPred (to ty1) (to ty2) ---------------- toIfaceContext :: ThetaType -> IfaceContext -toIfaceContext cs = map toIfacePred cs +toIfaceContext cs = map (toIfacePred toIfaceType) cs + +---------------- +coToIfaceType :: Coercion -> IfaceType +coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty] +coToIfaceType (TyConAppCo tc cos) = IfaceTyConApp (toIfaceTyCon tc) + (map coToIfaceType cos) +coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1) + (coToIfaceType co2) +coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v) + (coToIfaceType co) +coToIfaceType (PredCo pco) = IfacePredTy (toIfacePred coToIfaceType pco) +coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceTyCoVar cv) +coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con)) + (map coToIfaceType cos) +coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo + [ toIfaceType ty1 + , toIfaceType ty2 ] +coToIfaceType (SymCo co) = IfaceCoConApp IfaceSymCo + [ coToIfaceType co ] +coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo + [ coToIfaceType co1 + , coToIfaceType co2 ] +coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d) + [ coToIfaceType co ] +coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo + [ coToIfaceType co + , toIfaceType ty ] \end{code} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b940cb15a7..826ebda477 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -59,10 +59,10 @@ import Annotations import CoreSyn import CoreFVs import Class +import Kind import TyCon import DataCon import Type -import Coercion import TcType import InstEnv import FamInstEnv @@ -1387,14 +1387,16 @@ tyThingToIfaceDecl (ATyCon tycon) = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), - ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), - ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con), - ifConArgTys = map toIfaceType (dataConOrigArgTys data_con), + ifConUnivTvs = toIfaceTvBndrs univ_tvs, + ifConExTvs = toIfaceTvBndrs ex_tvs, + ifConEqSpec = to_eq_spec eq_spec, + ifConCtxt = toIfaceContext theta, + ifConArgTys = map toIfaceType arg_tys, ifConFields = map getOccName (dataConFieldLabels data_con), ifConStricts = dataConStrictMarks data_con } + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec] @@ -1402,6 +1404,8 @@ tyThingToIfaceDecl (ATyCon tycon) famInstToIface (Just (famTyCon, instTys)) = Just (toIfaceTyCon famTyCon, map toIfaceType instTys) +tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c) + tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier @@ -1566,6 +1570,8 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, -- construct the same ru_rough field as we have right now; -- see tcIfaceRule do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceType (coToIfaceType co) + do_arg arg = toIfaceExpr arg -- Compute orphanhood. See Note [Orphans] in IfaceSyn @@ -1585,15 +1591,16 @@ bogusIfaceRule id_name --------------------- toIfaceExpr :: CoreExpr -> IfaceExpr -toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit l) = IfaceLit l -toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) -toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) -toIfaceExpr (App f a) = toIfaceApp f [a] -toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as) -toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) -toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co) -toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co) +toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- toIfaceNote :: Note -> IfaceNote diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8dccc72b37..ef338615ea 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -21,6 +21,7 @@ import BuildTyCl import TcRnMonad import TcType import Type +import Coercion import TypeRep import HscTypes import Annotations @@ -39,7 +40,6 @@ import TyCon import DataCon import TysWiredIn import TysPrim ( anyTyConOfKind ) -import Var ( Var, TyVar ) import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv @@ -791,20 +791,55 @@ tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } +tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') } +tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- -tcIfacePredType :: IfacePredType -> IfL PredType -tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } -tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } -tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } +tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a) +tcIfacePred tc (IfaceClassP cls ts) + = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') } +tcIfacePred tc (IfaceIParam ip t) + = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') } +tcIfacePred tc (IfaceEqPred t1 t2) + = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mapM tcIfacePredType sts +tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts +\end{code} + +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ + +\begin{code} +tcIfaceCo :: IfaceType -> IfL Coercion +tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n +tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts +tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts +tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> + mkForAllCo tv' <$> tcIfaceCo t +tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co + +tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion +tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t +tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts +tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 +tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t +tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 +tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t +tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) + +tcIfaceCoVar :: FastString -> IfL CoVar +tcIfaceCoVar = tcIfaceLclId \end{code} @@ -819,6 +854,12 @@ tcIfaceExpr :: IfaceExpr -> IfL CoreExpr tcIfaceExpr (IfaceType ty) = Type <$> tcIfaceType ty +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + tcIfaceExpr (IfaceLcl name) = Var <$> tcIfaceLclId name @@ -853,7 +894,7 @@ tcIfaceExpr (IfaceLam bndr body) tcIfaceExpr (IfaceApp fun arg) = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg -tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut' <- tcIfaceExpr scrut case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let @@ -868,8 +909,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do extendIfaceIdEnv [case_bndr'] $ do alts' <- mapM (tcIfaceAlt scrut' tc_app) alts - ty' <- tcIfaceType ty - return (Case scrut' case_bndr' ty' alts') + return (Case scrut' case_bndr' (coreAltsType alts') alts') tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) = do { name <- newIfaceName (mkVarOccFS fs) @@ -898,11 +938,6 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) (idName id) (idType id) info ; return (setIdInfo id id_info, rhs') } -tcIfaceExpr (IfaceCast expr co) = do - expr' <- tcIfaceExpr expr - co' <- tcIfaceType co - return (Cast expr' co') - tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr case note of @@ -942,14 +977,13 @@ tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, co_tvs, arg_ids) + ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs con inst_tys - all_tvs = ex_tvs ++ co_tvs - ; rhs' <- extendIfaceTyVarEnv all_tvs $ + ; rhs' <- extendIfaceTyVarEnv ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } \end{code} @@ -1217,6 +1251,10 @@ tcIfaceClass :: Name -> IfL Class tcIfaceClass name = do { thing <- tcIfaceGlobal name ; return (tyThingClass thing) } +tcIfaceCoAxiom :: Name -> IfL CoAxiom +tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name + ; return (tyThingCoAxiom thing) } + tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9f504a10d1..a38761085c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -758,7 +758,7 @@ defaultDynFlags = SevOutput -> printOutput (msg style) SevInfo -> printErrs (msg style) SevFatal -> printErrs (msg style) - _ -> do + _ -> do hPutChar stderr '\n' printErrs ((mkLocMessage srcSpan msg) style) -- careful (#2302): printErrs prints in UTF-8, whereas @@ -1919,14 +1919,13 @@ forceRecompile :: DynP () -- recompiled which probably isn't what you want forceRecompile = do { dfs <- liftEwM getCmdLineState ; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) } - where + where force_recomp dfs = isOneShot (ghcMode dfs) setVerboseCore2Core :: DynP () setVerboseCore2Core = do forceRecompile setDynFlag Opt_D_verbose_core2core upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing }) - setDumpSimplPhases :: String -> DynP () setDumpSimplPhases s = do forceRecompile @@ -2044,7 +2043,6 @@ addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> D addImportPath "" = upd (\s -> s{importPaths = []}) addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) - addLibraryPath p = upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ca2e14cee2..db8887a47a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -171,7 +171,7 @@ module GHC ( pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprForAll, pprThetaArrow, + ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy, -- ** Entities TyThing(..), @@ -256,7 +256,6 @@ import Type import Coercion ( synTyConResKind ) import TcType hiding( typeKind ) import Id -import Var import TysPrim ( alphaTyVars ) import TyCon import Class @@ -388,7 +387,7 @@ runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. -> Ghc a -- ^ The action to perform. -> IO a runGhc mb_top_dir ghc = do - ref <- newIORef undefined + ref <- newIORef (panic "empty session") let session = Session ref flip unGhc session $ do initGhcMonad mb_top_dir @@ -406,7 +405,7 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => -> GhcT m a -- ^ The action to perform. -> m a runGhcT mb_top_dir ghct = do - ref <- liftIO $ newIORef undefined + ref <- liftIO $ newIORef (panic "empty session") let session = Session ref flip unGhcT session $ do initGhcMonad mb_top_dir diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e59c2239a7..b1b5fb1ffa 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -54,13 +54,13 @@ module HscTypes ( -- * TyThings and type environments TyThing(..), - tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, + tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom, implicitTyThings, isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - typeEnvDataCons, + typeEnvDataCons, typeEnvCoAxioms, -- * MonadThings MonadThings(..), @@ -1037,7 +1037,10 @@ implicitTyThings (ATyCon tc) -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) - + +implicitTyThings (ACoAxiom _cc) + = [] + implicitTyThings (AClass cl) = -- dictionary datatype: -- [extras_plus:] @@ -1069,10 +1072,10 @@ extras_plus thing = thing : implicitTyThings thing -- add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc - = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not - newTyConCo_maybe tc, + = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not + newTyConCo_maybe tc, -- Just if family instance, Nothing if not - tyConFamilyCoercion_maybe tc] + tyConFamilyCoercion_maybe tc] -- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y) @@ -1082,10 +1085,11 @@ implicitCoTyCon tc -- of some other declaration, or it is generated implicitly by some -- other declaration. isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (ADataCon _) = True -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (AClass _) = False -isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ADataCon {}) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (AClass {}) = False +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom {}) = True extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids @@ -1107,6 +1111,7 @@ emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom] typeEnvIds :: TypeEnv -> [Id] typeEnvDataCons :: TypeEnv -> [DataCon] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing @@ -1115,6 +1120,7 @@ emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] @@ -1170,6 +1176,11 @@ tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: TyThing -> CoAxiom +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) + -- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise tyThingClass :: TyThing -> Class tyThingClass (AClass cls) = cls diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d859784fad..3286b32d5d 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -24,7 +24,6 @@ import Id import IdInfo import TyCon import TcType -import Var import Name import Outputable import FastString @@ -45,7 +44,7 @@ type ShowMe = Name -> Bool ---------------------------- -- | Pretty-prints a 'TyThing' with its defining location. pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc -pprTyThingLoc pefas tyThing +pprTyThingLoc pefas tyThing = showWithLoc loc (pprTyThing pefas tyThing) where loc = pprNameLoc (GHC.getName tyThing) @@ -57,10 +56,11 @@ ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc ppr_ty_thing pefas _ (AnId id) = pprId pefas id ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon ppr_ty_thing pefas show_me (ATyCon tyCon) = pprTyCon pefas show_me tyCon +ppr_ty_thing _ _ (ACoAxiom _ ) = error "ppr_ty_thing (ACoCon)" -- BAY ppr_ty_thing pefas show_me (AClass cls) = pprClass pefas show_me cls -- | Pretty-prints a 'TyThing' in context: that is, if the entity --- is a data constructor, record selector, or class method, then +-- is a data constructor, record selector, or class method, then -- the entity's parent declaration is pretty-printed with irrelevant -- parts omitted. pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc @@ -77,7 +77,7 @@ pprTyThingInContextLoc pefas tyThing (pprTyThingInContext pefas tyThing) pprTyThingParent_maybe :: TyThing -> Maybe TyThing --- (pprTyThingParent_maybe x) returns (Just p) +-- (pprTyThingParent_maybe x) returns (Just p) -- when pprTyThingInContext sould print a declaration for p -- (albeit with some "..." in it) when asked to show x pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc)) @@ -94,6 +94,7 @@ pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc pprTyThingHdr pefas (AnId id) = pprId pefas id pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon +pprTyThingHdr _ (ACoAxiom _) = error "pprTyThingHdr (ACoCon)" -- BAY pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc @@ -103,7 +104,7 @@ pprTyConHdr _ tyCon | otherwise = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) where - vars | GHC.isPrimTyCon tyCon || + vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars | otherwise = GHC.tyConTyVars tyCon @@ -116,7 +117,7 @@ pprTyConHdr _ tyCon | otherwise = empty opt_stupid -- The "stupid theta" part of the declaration - | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon) + | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon) | otherwise = empty -- Returns 'empty' if null theta pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc @@ -125,14 +126,14 @@ pprDataConSig pefas dataCon pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc pprClassHdr _ cls - = ptext (sLit "class") <+> - GHC.pprThetaArrow (GHC.classSCTheta cls) <+> + = ptext (sLit "class") <+> + GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+> ppr_bndr cls <+> hsep (map ppr tyVars) <+> GHC.pprFundeps funDeps where (tyVars, funDeps) = GHC.classTvsFds cls - + pprId :: PrintExplicitForalls -> Var -> SDoc pprId pefas ident = hang (ppr_bndr ident <+> dcolon) @@ -147,7 +148,7 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc -- forall a. C a => forall b. Ord b => stuff -- Then we want to display -- (C a, Ord b) => stuff -pprTypeForUser print_foralls ty +pprTypeForUser print_foralls ty | print_foralls = ppr tidy_ty | otherwise = ppr (mkPhiTy ctxt ty') where @@ -160,7 +161,7 @@ pprTyCon pefas show_me tyCon = if GHC.isFamilyTyCon tyCon then pprTyConHdr pefas tyCon <+> dcolon <+> pprTypeForUser pefas (GHC.synTyConResKind tyCon) - else + else let rhs_type = GHC.synTyConType tyCon in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) | otherwise @@ -168,7 +169,7 @@ pprTyCon pefas show_me tyCon pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc pprAlgTyCon pefas show_me tyCon - | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ + | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ nest 2 (vcat (ppr_trim show_con datacons)) | otherwise = hang (pprTyConHdr pefas tyCon) 2 (add_bars (ppr_trim show_con datacons)) @@ -184,8 +185,8 @@ pprAlgTyCon pefas show_me tyCon pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc pprDataConDecl pefas show_me gadt_style dataCon | not gadt_style = ppr_fields tys_w_strs - | otherwise = ppr_bndr dataCon <+> dcolon <+> - sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ] + | otherwise = ppr_bndr dataCon <+> dcolon <+> + sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ] -- Printing out the dataCon as a type signature, in GADT style where (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon) @@ -214,15 +215,15 @@ pprDataConDecl pefas show_me gadt_style dataCon | null labels = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) | otherwise - = ppr_bndr dataCon <+> - braces (sep (punctuate comma (ppr_trim maybe_show_label + = ppr_bndr dataCon <+> + braces (sep (punctuate comma (ppr_trim maybe_show_label (zip labels fields)))) pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc pprClass pefas show_me cls | null methods = pprClassHdr pefas cls - | otherwise + | otherwise = hang (pprClassHdr pefas cls <+> ptext (sLit "where")) 2 (vcat (ppr_trim show_meth methods)) where @@ -237,7 +238,7 @@ pprClassMethod pefas id -- Here's the magic incantation to strip off the dictionary -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. -- - -- It's important to tidy it *before* splitting it up, so that if + -- It's important to tidy it *before* splitting it up, so that if -- we have class C a b where -- op :: forall a. a -> b -- then the inner forall on op gets renamed to a1, and we print @@ -268,7 +269,7 @@ ppr_bndr :: GHC.NamedThing a => a -> SDoc ppr_bndr a = GHC.pprParenSymName a showWithLoc :: SDoc -> SDoc -> SDoc -showWithLoc loc doc +showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) -- The tab tries to make them line up a bit where diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index f23280bc19..b4296cbb07 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1156,6 +1156,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts cafRefs p (Note _n e) = cafRefs p e cafRefs p (Cast e _co) = cafRefs p e cafRefs _ (Type _) = fastBool False +cafRefs _ (Coercion _) = fastBool False cafRefss :: VarEnv Id -> [Expr a] -> FastBool cafRefss _ [] = fastBool False diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 8bf94539fa..3f2b32a8b3 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -269,7 +269,7 @@ exp :: { IfaceExpr } | '%let' let_bind '%in' exp { IfaceLet $2 $4 } -- gaw 2004 | '%case' '(' ty ')' aexp '%of' id_bndr - '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } + '{' alts1 '}' { IfaceCase $5 (fst $7) $9 } | '%cast' aexp aty { IfaceCast $2 $3 } -- No InlineMe any more -- | '%note' STRING exp diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 24756d5bae..b7396a7233 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1003,11 +1003,12 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey :: Unique + funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 -stableNameTyConKey = mkPreludeTyConUnique 52 -mutVarPrimTyConKey = mkPreludeTyConUnique 55 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPredPrimTyConKey = mkPreludeTyConUnique 53 +mutVarPrimTyConKey = mkPreludeTyConUnique 55 ioTyConKey = mkPreludeTyConUnique 56 wordPrimTyConKey = mkPreludeTyConUnique 58 wordTyConKey = mkPreludeTyConUnique 59 @@ -1047,9 +1048,8 @@ eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors -tySuperKindTyConKey, coSuperKindTyConKey :: Unique +tySuperKindTyConKey :: Unique tySuperKindTyConKey = mkPreludeTyConUnique 85 -coSuperKindTyConKey = mkPreludeTyConUnique 86 -- Kind constructors liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey, @@ -1238,6 +1238,9 @@ mapIdKey = mkPreludeMiscIdUnique 69 groupWithIdKey = mkPreludeMiscIdUnique 70 dollarIdKey = mkPreludeMiscIdUnique 71 +coercionTokenIdKey :: Unique +coercionTokenIdKey = mkPreludeMiscIdUnique 72 + -- Parallel array functions singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey, filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey, diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index b37556be12..b01c6c110d 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -527,7 +527,7 @@ For dataToTag#, we can reduce if either dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr) dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] | tag_to_enum `hasKey` tagToEnumKey - , ty1 `coreEqType` ty2 + , ty1 `eqType` ty2 = Just tag -- dataToTag (tagToEnum x) ==> x dataToTagRule id_unf [_, val_arg] @@ -600,7 +600,7 @@ match_append_lit _ [Type ty1, ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 - = ASSERT( ty1 `coreEqType` ty2 ) + = ASSERT( ty1 `eqType` ty2 ) Just (Var unpk `App` Type ty1 `App` Lit (MachStr (s1 `appendFS` s2)) `App` c1 diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index ac3a528f36..4b3492b2c0 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -14,7 +14,22 @@ module TysPrim( openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar, - primTyCons, + -- Kind constructors... + tySuperKindTyCon, tySuperKind, + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + tySuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName, + + -- Kinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + mkArrowKind, mkArrowKinds, isCoercionKind, + + funTyCon, funTyConName, + primTyCons, charPrimTyCon, charPrimTy, intPrimTyCon, intPrimTy, @@ -44,7 +59,9 @@ module TysPrim( word32PrimTyCon, word32PrimTy, int64PrimTyCon, int64PrimTy, - word64PrimTyCon, word64PrimTy, + word64PrimTyCon, word64PrimTy, + + eqPredPrimTyCon, -- ty1 ~ ty2 -- * Any anyTyCon, anyTyConOfKind, anyTypeOfKind @@ -54,11 +71,9 @@ module TysPrim( import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) -import OccName ( mkTcOcc ) -import OccName ( mkTyVarOccFS, mkTcOccFS ) -import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon ) -import Type -import Coercion +import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS ) +import TyCon +import TypeRep import SrcLoc import Unique ( mkAlphaTyVarUnique ) import PrelNames @@ -102,6 +117,7 @@ primTyCons , word32PrimTyCon , word64PrimTyCon , anyTyCon + , eqPredPrimTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -111,7 +127,7 @@ mkPrimTc fs unique tycon (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -122,8 +138,9 @@ word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon -statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon -realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +eqPredPrimTyConName = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon @@ -193,109 +210,95 @@ argBetaTy = mkTyVarTy argBetaTyVar %************************************************************************ %* * - Any + FunTyCon %* * %************************************************************************ -Note [Any types] -~~~~~~~~~~~~~~~~ -The type constructor Any::* has these properties - - * It is defined in module GHC.Prim, and exported so that it is - available to users. For this reason it's treated like any other - primitive type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache - - built with TyCon.PrimTyCon - - * It is lifted, and hence represented by a pointer - - * It is inhabited by at least one value, namely bottom - - * You can unsafely coerce any lifted type to Ayny, and back. - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - - * It is used to instantiate otherwise un-constrained type variables of kind * - For example length Any [] - See Note [Strangely-kinded void TyCons] - -In addition, we have a potentially-infinite family of types, one for -each kind /other than/ *, needed to instantiate otherwise -un-constrained type variables of kinds other than *. This is a bit -like tuples; there is a potentially-infinite family. They have slightly -different characteristics to Any::*: - - * They are built with TyCon.AnyTyCon - * They have non-user-writable names like "Any(*->*)" - * They are not exported by GHC.Prim - * They are uninhabited (of course; not kind *) - * They have a unique derived from their OccName (see Note [Uniques of Any]) - * Their Names do not live in the global name cache - -Note [Uniques of Any] -~~~~~~~~~~~~~~~~~~~~~ -Although Any(*->*), say, doesn't have a binding site, it still needs -to have a Unique. Unlike tuples (which are also an infinite family) -there is no convenient way to index them, so we use the Unique from -their OccName instead. That should be unique, - - both wrt each other, because their strings differ - - - and wrt any other Name, because Names get uniques with - various 'char' tags, but the OccName of Any will - get a Unique built with mkTcOccUnique, which has a particular 'char' - tag; see Unique.mkTcOccUnique! - -Note [Strangely-kinded void TyCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #959 for more examples +\begin{code} +funTyConName :: Name +funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon + +funTyCon :: TyCon +funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) + -- You might think that (->) should have type (?? -> ? -> *), and you'd be right + -- But if we do that we get kind errors when saying + -- instance Control.Arrow (->) + -- becuase the expected kind is (*->*->*). The trouble is that the + -- expected/actual stuff in the unifier does not go contra-variant, whereas + -- the kind sub-typing does. Sigh. It really only matters if you use (->) in + -- a prefix way, thus: (->) Int# Int#. And this is unusual. + -- because they are never in scope in the source +\end{code} -When the type checker finds a type variable with no binding, which -means it can be instantiated with an arbitrary type, it usually -instantiates it to Void. Eg. - length [] -===> - length Any (Nil Any) +%************************************************************************ +%* * + Kinds +%* * +%************************************************************************ -But in really obscure programs, the type variable might have a kind -other than *, so we need to invent a suitably-kinded type. +\begin{code} +-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's +tySuperKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, + ubxTupleKindTyCon, argTypeKindTyCon + :: TyCon +tySuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName + :: Name + +tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind +ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind +argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind + +-------------------------- +-- ... and now their names + +tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon +liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon +openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon +unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon +ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon +argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon + +mkPrimTyConName :: FastString -> Unique -> TyCon -> Name +mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) + key + (ATyCon tycon) + BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, + -- because they are never in scope in the source +\end{code} -This commit uses - Any for kind * - Any(*->*) for kind *->* - etc \begin{code} -anyTyConName :: Name -anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon +kindTyConType :: TyCon -> Type +kindTyConType kind = TyConApp kind [] -anyTyCon :: TyCon -anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep +-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's +liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind -anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] +liftedTypeKind = kindTyConType liftedTypeKindTyCon +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon +openTypeKind = kindTyConType openTypeKindTyCon +argTypeKind = kindTyConType argTypeKindTyCon +ubxTupleKind = kindTyConType ubxTupleKindTyCon -anyTyConOfKind :: Kind -> TyCon --- Map all superkinds of liftedTypeKind to liftedTypeKind -anyTyConOfKind kind - | liftedTypeKind `isSubKind` kind = anyTyCon - | otherwise = tycon - where - -- Derive the name from the kind, thus: - -- Any(*->*), Any(*->*->*) - -- These are names that can't be written by the user, - -- and are not allocated in the global name cache - str = "Any" ++ showSDoc (pprParendKind kind) +-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ +mkArrowKind :: Kind -> Kind -> Kind +mkArrowKind k1 k2 = FunTy k1 k2 - occ = mkTcOcc str - uniq = getUnique occ -- See Note [Uniques of Any] - name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax - tycon = mkAnyTyCon name kind -\end{code} +-- | Iterated application of 'mkArrowKind' +mkArrowKinds :: [Kind] -> Kind -> Kind +mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds +tySuperKind :: SuperKind +tySuperKind = kindTyConType tySuperKindTyCon +\end{code} %************************************************************************ %* * @@ -388,8 +391,12 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy :: Type -> Type mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] + statePrimTyCon :: TyCon statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep + +eqPredPrimTyCon :: TyCon -- The representation type for equality predicates +eqPredPrimTyCon = pcPrimTyCon eqPredPrimTyConName 2 VoidRep \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -551,3 +558,110 @@ threadIdPrimTy = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep \end{code} + + + +%************************************************************************ +%* * + Any +%* * +%************************************************************************ + +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any::* has these properties + + * It is defined in module GHC.Prim, and exported so that it is + available to users. For this reason it's treated like any other + primitive type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + - built with TyCon.PrimTyCon + + * It is lifted, and hence represented by a pointer + + * It is inhabited by at least one value, namely bottom + + * You can unsafely coerce any lifted type to Ayny, and back. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is used to instantiate otherwise un-constrained type variables of kind * + For example length Any [] + See Note [Strangely-kinded void TyCons] + +In addition, we have a potentially-infinite family of types, one for +each kind /other than/ *, needed to instantiate otherwise +un-constrained type variables of kinds other than *. This is a bit +like tuples; there is a potentially-infinite family. They have slightly +different characteristics to Any::*: + + * They are built with TyCon.AnyTyCon + * They have non-user-writable names like "Any(*->*)" + * They are not exported by GHC.Prim + * They are uninhabited (of course; not kind *) + * They have a unique derived from their OccName (see Note [Uniques of Any]) + * Their Names do not live in the global name cache + +Note [Uniques of Any] +~~~~~~~~~~~~~~~~~~~~~ +Although Any(*->*), say, doesn't have a binding site, it still needs +to have a Unique. Unlike tuples (which are also an infinite family) +there is no convenient way to index them, so we use the Unique from +their OccName instead. That should be unique, + - both wrt each other, because their strings differ + + - and wrt any other Name, because Names get uniques with + various 'char' tags, but the OccName of Any will + get a Unique built with mkTcOccUnique, which has a particular 'char' + tag; see Unique.mkTcOccUnique! + +Note [Strangely-kinded void TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #959 for more examples + +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. + + length [] +===> + length Any (Nil Any) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. + +This commit uses + Any for kind * + Any(*->*) for kind *->* + etc + +\begin{code} +anyTyConName :: Name +anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] + +anyTyConOfKind :: Kind -> TyCon +-- Map all superkinds of liftedTypeKind to liftedTypeKind +anyTyConOfKind kind + | isLiftedTypeKind kind = anyTyCon + | otherwise = tycon + where + -- Derive the name from the kind, thus: + -- Any(*->*), Any(*->*->*) + -- These are names that can't be written by the user, + -- and are not allocated in the global name cache + str = "Any" ++ showSDoc (pprParendKind kind) + + occ = mkTcOcc str + uniq = getUnique occ -- See Note [Uniques of Any] + name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax + tycon = mkAnyTyCon name kind +\end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index db2ea1b55e..9f5f369a99 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -64,23 +64,14 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) +import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) +import Var +import TyCon +import TypeRep import RdrName import Name -import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) -import Var -import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, - mkTupleTyCon, mkAlgTyCon, tyConName, - TyConParent(NoParentTyCon) ) - -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) - -import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, - TyThing(..) ) -import Coercion ( unsafeCoercionTyCon, symCoercionTyCon, - transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon ) -import TypeRep ( mkArrowKinds, liftedTypeKind, ubxTupleKind ) -import Unique ( incrUnique, mkTupleTyConUnique, +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) +import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array import FastString @@ -124,12 +115,6 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , intTyCon , listTyCon , parrTyCon - , unsafeCoercionTyCon - , symCoercionTyCon - , transCoercionTyCon - , leftCoercionTyCon - , rightCoercionTyCon - , instCoercionTyCon ] \end{code} @@ -610,5 +595,3 @@ mkPArrFakeCon arity = data_con isPArrFakeCon :: DataCon -> Bool isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) \end{code} - - diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 6c57cb2aa8..503953d4a0 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -455,7 +455,7 @@ rnBind :: (Name -> [Name]) -- Signature tyvar function rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat , pat_rhs = grhss -- pat fvs were stored in bind_fvs - -- after processing the LHS + -- after processing the LHS , bind_fvs = pat_fvs })) = setSrcSpan loc $ do { let bndrs = collectPatBinders pat @@ -475,7 +475,7 @@ rnBind sig_fn trim , fun_infix = is_infix , fun_matches = matches })) -- invariant: no free vars here when it's a FunBind - = setSrcSpan loc $ + = setSrcSpan loc $ do { let plain_name = unLoc name ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 3a20ac48b6..46058c4677 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -18,7 +18,7 @@ import HsSyn import TcEnv ( isBrackStage ) import RnEnv import RnHsDoc ( rnHsDoc ) -import IfaceEnv ( ifaceExportNames ) +import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 138ffa29f2..e711417f85 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -31,7 +31,7 @@ import RnEnv import TcRnMonad import RdrName import PrelNames -import TypeRep ( funTyConName ) +import TysPrim ( funTyConName ) import Name import SrcLoc import NameSet diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 523431fec0..5bec8f0c3d 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -207,6 +207,7 @@ do_one env (id, rhs) tryForCSE :: CSEnv -> CoreExpr -> CoreExpr tryForCSE _ (Type t) = Type t +tryForCSE _ (Coercion c) = Coercion c tryForCSE env expr = case lookupCSEnv env expr' of Just smaller_expr -> smaller_expr Nothing -> expr' @@ -215,6 +216,7 @@ tryForCSE env expr = case lookupCSEnv env expr' of cseExpr :: CSEnv -> CoreExpr -> CoreExpr cseExpr _ (Type t) = Type t +cseExpr _ (Coercion co) = Coercion co cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = Var (lookupSubst env v) cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index b9f44c95c1..82825c3abe 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -129,7 +129,9 @@ fiExpr :: FloatingBinds -- Binds we're trying to drop fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) - Type ty + Type ty +fiExpr to_drop (_, AnnCoercion co) = ASSERT( null to_drop ) + Coercion co fiExpr to_drop (_, AnnCast expr co) = Cast (fiExpr to_drop expr) co -- Just float in past coercion @@ -198,7 +200,7 @@ fiExpr to_drop lam@(_, AnnLam _ _) go seen_one_shot_id [] = seen_one_shot_id go seen_one_shot_id (b:bs) - | isTyCoVar b = go seen_one_shot_id bs + | isTyVar b = go seen_one_shot_id bs | isOneShotBndr b = go True bs | otherwise = False -- Give up at a non-one-shot Id \end{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 2a51a2100e..e5db7d93ce 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -225,6 +225,7 @@ floatRhs lvl arg -- Used for nested non-rec rhss, and fn args ----------------- floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v) floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co) floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit) floatExpr lvl (App e a) diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index 2b190621d6..fe1f758551 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -199,6 +199,7 @@ libCase :: LibCaseEnv libCase env (Var v) = libCaseId env v libCase _ (Lit lit) = Lit lit libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co libCase env (App fun arg) = App (libCase env fun) (libCase env arg) libCase env (Note note body) = Note note (libCase env body) libCase env (Cast e co) = Cast (libCase env e) co diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 7692b628ab..c593e81eb6 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -19,17 +19,18 @@ module OccurAnal ( import CoreSyn import CoreFVs -import Type ( tyVarsOfType ) -import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp ) -import Coercion ( CoercionI(..), mkSymCoI ) +import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce ) import Id import NameEnv import NameSet import Name ( Name, localiseName ) import BasicTypes +import Coercion + import VarSet import VarEnv -import Var ( varUnique ) +import Var + import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) @@ -97,7 +98,12 @@ occAnalBind :: OccEnv -- The incoming OccEnv [CoreBind]) occAnalBind env _ (NonRec binder rhs) body_usage - | isTyCoVar binder -- A type let; we don't gather usage info + | isTyVar binder -- A type let; we don't gather usage info + = (body_usage, [NonRec binder rhs]) + + | isCoVar binder -- A coercion let; again no usage info + -- We trust that it'll get inlined away + -- as soon as it takes form (cv = Coercion co) = (body_usage, [NonRec binder rhs]) | not (binder `usedIn` body_usage) -- It's not mentioned @@ -381,7 +387,7 @@ occAnalBind _ env (Rec pairs) body_usage make_node (bndr, rhs) = (details, varUnique bndr, keysUFM out_edges) - where + where details = ND { nd_bndr = bndr, nd_rhs = rhs' , nd_uds = rhs_usage3, nd_inl = inl_fvs} @@ -872,33 +878,27 @@ occAnal :: OccEnv -> (UsageDetails, -- Gives info only about the "interesting" Ids CoreExpr) -occAnal _ (Type t) = (emptyDetails, Type t) -occAnal env (Var v) = (mkOneOcc env v False, Var v) +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var v) = (mkOneOcc env v False, expr) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. -- But that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. -\end{code} - -We regard variables that occur as constructor arguments as "dangerousToDup": - -\begin{verbatim} -module A where -f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -\end{verbatim} -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. +occAnal _ (Coercion co) + = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion veriables] +\end{code} -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. +Note [Gather occurrences of coercion veriables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. \begin{code} -occAnal _ expr@(Lit _) = (emptyDetails, expr) \end{code} \begin{code} @@ -914,7 +914,10 @@ occAnal env (Note note body) occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (markManyIf (isRhsEnv env) usage, Cast expr' co) + let usage1 = markManyIf (isRhsEnv env) usage + usage2 = addIdOccs usage1 (coVarsOfCo co) + -- See Note [Gather occurrences of coercion veriables] + in (usage2, Cast expr' co) -- If we see let x = y `cast` co -- then mark y as 'Many' so that we don't -- immediately inline y again. @@ -929,7 +932,7 @@ occAnal env app@(App _ _) -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment -occAnal env (Lam x body) | isTyCoVar x +occAnal env (Lam x body) | isTyVar x = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') } @@ -1021,6 +1024,18 @@ occAnalArgs env args Applications are dealt with specially because we want the "build hack" to work. +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. + \begin{code} occAnalApp :: OccEnv -> (Expr CoreBndr, [Arg CoreBndr]) @@ -1036,6 +1051,7 @@ occAnalApp env (Var fun, args) -- arguments are just variables, or trivial expressions. -- -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where @@ -1146,7 +1162,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body) where (body_usg', tagged_bndr) = tagBinder body_usg bndr rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info - rhs = mkCoerceI co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings] + rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings] \end{code} @@ -1355,7 +1371,7 @@ extendFvs env s data ProxyEnv -- See Note [ProxyEnv] = PE (IdEnv -- Domain = scrutinee variables (Id, -- The scrutinee variable again - [(Id,CoercionI)])) -- The case binders that it maps to + [(Id,Coercion)])) -- The case binders that it maps to VarSet -- Free variables of both range and domain \end{code} @@ -1572,7 +1588,7 @@ binder-swap unconditionally and still get occurrence analysis information right. \begin{code} -extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv +extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv -- (extendPE x co y) typically arises from -- case (x |> co) of y { ... } -- It extends the proxy env with the binding @@ -1585,7 +1601,7 @@ extendProxyEnv pe scrut co case_bndr env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co) single cb_co = (scrut1, [cb_co]) add cb_co (x, cb_cos) = (x, cb_co:cb_cos) - fvs2 = fvs1 `unionVarSet` freeVarsCoI co + fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co `extendVarSet` case_bndr `extendVarSet` scrut1 @@ -1596,7 +1612,7 @@ extendProxyEnv pe scrut co case_bndr -- Also we don't want any INLINE or NOINLINE pragmas! ----------- -type ProxyBind = (Id, Id, CoercionI) +type ProxyBind = (Id, Id, Coercion) -- (scrut variable, case-binder variable, coercion) getProxies :: OccEnv -> Id -> Bag ProxyBind @@ -1607,7 +1623,7 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr = -- pprTrace "wrapProxies" (ppr case_bndr) $ go_fwd case_bndr where - fwd_pe :: IdEnv (Id, CoercionI) + fwd_pe :: IdEnv (Id, Coercion) fwd_pe = foldVarEnv add1 emptyVarEnv pe where add1 (x,ycos) env = foldr (add2 x) env ycos @@ -1621,23 +1637,23 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr go_fwd' case_bndr | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr - = unitBag (scrut, case_bndr, mkSymCoI co) + = unitBag (scrut, case_bndr, mkSymCo co) `unionBags` go_fwd scrut `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut , cb /= case_bndr] | otherwise = emptyBag - lookup_bwd :: Id -> [(Id, CoercionI)] + lookup_bwd :: Id -> [(Id, Coercion)] -- Return case_bndrs that are connected to scrut lookup_bwd scrut = case lookupVarEnv pe scrut of Nothing -> [] Just (_, cb_cos) -> cb_cos - go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind + go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos - go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind + go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind go_bwd1 scrut (case_bndr, co) = -- pprTrace "go_bwd1" (ppr case_bndr) $ unitBag (case_bndr, scrut, co) @@ -1652,9 +1668,9 @@ mkAltEnv env scrut cb where pe = occ_proxy env pe' = case scrut of - Var v -> extendProxyEnv pe v (IdCo (idType v)) cb - Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb - _other -> trimProxyEnv pe [cb] + Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb + Cast (Var v) co -> extendProxyEnv pe v co cb + _other -> trimProxyEnv pe [cb] ----------- trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv @@ -1675,12 +1691,7 @@ trimProxyEnv (PE pe fvs) bndrs trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, []) | otherwise = (scrut, filterOut discard cb_cos) discard (cb,co) = bndr_set `intersectsVarSet` - extendVarSet (freeVarsCoI co) cb - ------------ -freeVarsCoI :: CoercionI -> VarSet -freeVarsCoI (IdCo t) = tyVarsOfType t -freeVarsCoI (ACo co) = tyVarsOfType co + extendVarSet (tyCoVarsOfCo co) cb \end{code} @@ -1747,7 +1758,7 @@ tagBinder usage binder setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr - | isTyCoVar bndr = bndr + | isTyVar bndr = bndr | isExportedId bndr = case idOccInfo bndr of NoOccInfo -> bndr _ -> setIdOccInfo bndr NoOccInfo diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs index d398055744..61182895cf 100644 --- a/compiler/simplCore/SAT.lhs +++ b/compiler/simplCore/SAT.lhs @@ -56,6 +56,7 @@ import Var import CoreSyn import CoreUtils import Type +import Coercion import Id import Name import VarEnv @@ -112,7 +113,7 @@ satBind (Rec pairs) interesting_ids = do return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') \end{code} \begin{code} -data App = VarApp Id | TypeApp Type +data App = VarApp Id | TypeApp Type | CoApp Coercion data Staticness a = Static a | NotStatic type IdAppInfo = (Id, SATInfo) @@ -133,6 +134,7 @@ pprSATInfo staticness = hcat $ map pprStaticness staticness pprStaticness :: Staticness App -> SDoc pprStaticness (Static (VarApp _)) = ptext (sLit "SV") pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") +pprStaticness (Static (CoApp _)) = ptext (sLit "SC") pprStaticness NotStatic = ptext (sLit "NS") @@ -142,7 +144,8 @@ mergeSATInfo _ [] = [] mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps mergeSATInfo ((Static (VarApp v)):statics) ((Static (VarApp v')):apps) = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps -mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `coreEqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps +mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps +mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps) = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps mergeSATInfo l r = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ") <> ptext (sLit "Right:") <> pprSATInfo r @@ -154,9 +157,9 @@ mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo bindersToSATInfo :: [Id] -> SATInfo bindersToSATInfo vs = map (Static . binderToApp) vs - where binderToApp v = if isId v - then VarApp v - else TypeApp $ mkTyVarTy v + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo finalizeApp Nothing id_sat_info = id_sat_info @@ -195,9 +198,10 @@ satExpr (App fn arg) interesting_ids = do -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) in case arg of - Type t -> satRemainderWithStaticness $ Static (TypeApp t) - Var v -> satRemainderWithStaticness $ Static (VarApp v) - _ -> satRemainderWithStaticness $ NotStatic + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic where boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) boring fn' sat_info_fn app_info = @@ -229,6 +233,9 @@ satExpr (Note note expr) interesting_ids = do satExpr ty@(Type _) _ = do return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = do + return (co, emptyIdSATInfo, Nothing) satExpr (Cast expr coercion) interesting_ids = do (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 6871faa798..b1af4b3d6f 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -243,6 +243,7 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well. \begin{code} lvlExpr _ _ ( _, AnnType ty) = return (Type ty) +lvlExpr _ _ ( _, AnnCoercion co) = return (Coercion co) lvlExpr _ env (_, AnnVar v) = return (lookupVar env v) lvlExpr _ _ (_, AnnLit lit) = return (Lit lit) @@ -423,7 +424,9 @@ lvlMFE True ctxt_lvl env e@(_, AnnCase {}) = lvlExpr ctxt_lvl env e -- Don't share cases lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) - | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] + | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] + -- This includes coercions, which we don't + -- want to float anyway || notWorthFloating ann_expr abs_vars || not good_destination = -- Don't float it out @@ -491,6 +494,7 @@ notWorthFloating e abs_vars go (_, AnnCast e _) n = go e n go (_, AnnApp e arg) n | (_, AnnType {}) <- arg = go e n + | (_, AnnCoercion {}) <- arg = go e n | n==0 = False | is_triv arg = go e (n-1) | otherwise = False @@ -500,6 +504,7 @@ notWorthFloating e abs_vars is_triv (_, AnnVar {}) = True -- (ie not worth floating) is_triv (_, AnnCast e _) = is_triv e is_triv (_, AnnApp e (_, AnnType {})) = is_triv e + is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e is_triv _ = False \end{code} @@ -563,7 +568,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone -> LvlM (LevelledBind, LevelEnv) lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | isTyCoVar bndr -- Don't do anything for TyVar binders + | isTyVar bndr -- Don't do anything for TyVar binders -- (simplifier gets rid of them pronto) = do rhs' <- lvlExpr ctxt_lvl env rhs return (NonRec (TB bndr ctxt_lvl) rhs', env) @@ -883,7 +888,7 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs (False, True) -> False _ -> v1 <= v2 -- Same family - is_tv v = isTyCoVar v && not (isCoVar v) + is_tv v = isTyVar v uniq :: [Var] -> [Var] -- Remove adjacent duplicates; the sort will have brought them together @@ -914,9 +919,7 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] absVarsOf id_env v | isId v = [av2 | av1 <- lookup_avs v , av2 <- add_tyvars av1] - | isCoVar v = add_tyvars v - | otherwise = [v] - + | otherwise = ASSERT( isTyVar v ) [v] where lookup_avs v = case lookupVarEnv id_env v of Just (abs_vars, _) -> abs_vars diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index d9eea39ed6..668c969709 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -16,7 +16,7 @@ module SimplEnv ( -- Environments SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, + mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, getSimplRules, @@ -24,8 +24,10 @@ module SimplEnv ( SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, - simplBinder, simplBinders, addBndrRules, - substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst, + simplBinder, simplBinders, addBndrRules, + substExpr, substTy, substTyVar, getTvSubst, + getCvSubst, substCo, substCoVar, + mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -49,9 +51,10 @@ import Id import MkCore import TysWiredIn import qualified CoreSubst -import qualified Type ( substTy, substTyVarBndr, substTyVar ) +import qualified Type import Type hiding ( substTy, substTyVarBndr, substTyVar ) -import Coercion +import qualified Coercion +import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr ) import BasicTypes import MonadUtils import Outputable @@ -107,8 +110,9 @@ data SimplEnv seCC :: CostCentreStack, -- The enclosing CCS (when profiling) -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion + seIdSubst :: SimplIdSubst, -- InId |--> OutExpr ----------- Dynamic part of the environment ----------- -- Dynamic in the sense of describing the setup where @@ -143,13 +147,14 @@ data SimplSR = DoneEx OutExpr -- Completed term | DoneId OutId -- Completed term variable | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv SimplIdSubst InExpr instance Outputable SimplSR where ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v - ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, + ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -227,6 +232,7 @@ mkSimplEnv mode , seInScope = init_in_scope , seFloats = emptyFloats , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv , seIdSubst = emptyVarEnv } -- The top level "enclosing CC" is "SUBSUMED". @@ -279,6 +285,10 @@ extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res = env {seTvSubst = extendVarEnv subst var res} +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res + = env {seCvSubst = extendVarEnv subst var res} + --------------------- getInScope :: SimplEnv -> InScopeSet getInScope env = seInScope env @@ -318,13 +328,13 @@ modifyInScope env@(SimplEnv {seInScope = in_scope}) v --------------------- zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} -setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv -setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e \end{code} @@ -503,7 +513,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v Just (DoneId v) -> DoneId (refine in_scope v) Just (DoneEx (Var v)) -> DoneId (refine in_scope v) Just res -> res -- DoneEx non-var, or ContEx - where -- Get the most up-to-date thing from the in-scope set -- Even though it isn't in the substitution, it may be in @@ -549,8 +558,10 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- The substitution is extended only if the variable is cloned, because -- we *don't* need to use it to track occurrence info. simplBinder env bndr - | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr ; seqTyVar tv `seq` return (env', tv) } + | isCoVar bndr = do { let (env', tv) = substCoVarBndr env bndr + ; seqId tv `seq` return (env', tv) } | otherwise = do { let (env', id) = substIdBndr env bndr ; seqId id `seq` return (env', id) } @@ -714,6 +725,10 @@ getTvSubst :: SimplEnv -> TvSubst getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) = mkTvSubst in_scope tv_env +getCvSubst :: SimplEnv -> CvSubst +getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = CvSubst in_scope tv_env cv_env + substTy :: SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTvSubst env) ty @@ -724,7 +739,19 @@ substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv = case Type.substTyVarBndr (getTvSubst env) tv of (TvSubst in_scope' tv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getCvSubst env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getCvSubst env) co -- When substituting in rules etc we can get CoreSubst to do the work -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match @@ -732,19 +759,19 @@ substTyVarBndr env tv -- the substitutions are typically small, and laziness will avoid work in many cases. mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst -mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) - = mk_subst tv_env id_env +mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env }) + = mk_subst tv_env cv_env id_env where - mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) + mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env) - fiddle (DoneEx e) = e - fiddle (DoneId v) = Var v - fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e + fiddle (DoneEx e) = e + fiddle (DoneId v) = Var v + fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e -- Don't shortcut here ------------------ substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) -- The tyVarsOfType is cheaper than it looks diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 7e9a010051..976bb873d9 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -36,6 +36,7 @@ import StaticFlags import CoreSyn import qualified CoreSubst import PprCore +import DataCon ( dataConCannotMatch ) import CoreFVs import CoreUtils import CoreArity @@ -45,17 +46,16 @@ import Id import Var import Demand import SimplMonad -import TcType ( isDictLikeTy ) import Type hiding( substTy ) -import Coercion ( coercionKind ) +import Coercion hiding( substCo ) import TyCon -import Unify ( dataConCannotMatch ) import VarSet import BasicTypes import Util import MonadUtils import Outputable import FastString +import Pair import Data.List \end{code} @@ -208,6 +208,7 @@ contIsDupable _ = False contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont +contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont contIsTrivial (CoerceIt _ cont) = contIsTrivial cont contIsTrivial _ = False @@ -216,17 +217,19 @@ contResultType :: SimplEnv -> OutType -> SimplCont -> OutType contResultType env ty cont = go cont ty where - subst_ty se ty = substTy (se `setInScope` env) ty + subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty + subst_co se co = SimplEnv.substCo (se `setInScope` env) co go (Stop {}) ty = ty - go (CoerceIt co cont) _ = go cont (snd (coercionKind co)) + go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co)) go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body))) go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai)) go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts)) go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se) - apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) - apply_to_arg ty _ _ = funResultTy ty + apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) + apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg) + apply_to_arg ty _ _ = funResultTy ty argInfoResultTy :: ArgInfo -> OutType argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) @@ -235,6 +238,7 @@ argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) ------------------- countValArgs :: SimplCont -> Int countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont +countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont countValArgs _ = 0 @@ -1032,9 +1036,9 @@ mkLam _env bndrs body | not (any bad bndrs) -- Note [Casts and lambdas] = do { lam <- mkLam' dflags bndrs body - ; return (mkCoerce (mkPiTypes bndrs co) lam) } + ; return (mkCoerce (mkPiCos bndrs co) lam) } where - co_vars = tyVarsOfType co + co_vars = tyCoVarsOfCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars mkLam' dflags bndrs body@(Lam {}) @@ -1048,7 +1052,7 @@ mkLam _env bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | otherwise + | otherwise = return (mkLams bndrs body) \end{code} @@ -1091,9 +1095,6 @@ because the latter is not well-kinded. %* * %************************************************************************ -When we meet a let-binding we try eta-expansion. To find the -arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis] - \begin{code} tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] @@ -1336,9 +1337,7 @@ abstractFloats main_tvs body_env body ; return (subst', (NonRec poly_id poly_rhs)) } where rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions] - | otherwise - = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs') + tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') -- Abstract only over the type variables free in the rhs -- wrt which the new binding is abstracted. But the naive @@ -1550,9 +1549,8 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) [con] -> -- It matches exactly one constructor, so fill it in do { tick (FillInCaseDefault case_bndr) ; us <- getUniquesM - ; let (ex_tvs, co_tvs, arg_ids) = - dataConRepInstPat us con inst_tys - ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] } + ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] } _ -> return [(DEFAULT, [], deflt_rhs)] diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 8249c89425..4020a765b7 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -17,10 +17,9 @@ import FamInstEnv ( FamInstEnv ) import Id import MkId ( seqId, realWorldPrimId ) import MkCore ( mkImpossibleExpr ) -import Var import IdInfo import Name ( mkSystemVarName, isExternalName ) -import Coercion +import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst ) import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) @@ -42,6 +41,7 @@ import Maybes ( orElse, isNothing ) import Data.List ( mapAccumL ) import Outputable import FastString +import Pair \end{code} @@ -371,6 +371,8 @@ simplNonRecX :: SimplEnv simplNonRecX env bndr new_rhs | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p } = return env -- Here b is dead, and we avoid creating + | Coercion co <- new_rhs + = return (extendCvSubst env bndr co) | otherwise -- the binding b = (a,b) = do { (env', bndr') <- simplBinder env bndr ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } @@ -438,7 +440,7 @@ That's what the 'go' loop in prepareRhs does prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] - | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type + | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs ; return (env', Cast rhs' co) } @@ -658,7 +660,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs final_id = new_bndr `setIdInfo` info3 - ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $ return (addNonRec env final_id final_rhs) } } -- The addNonRec adds it to the in-scope set too @@ -874,14 +876,14 @@ simplExprF env e cont simplExprF' :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVarF env v cont +simplExprF' env (Var v) cont = simplIdF env v cont simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont simplExprF' env (Note n expr) cont = simplNote env n expr cont simplExprF' env (Cast body co) cont = simplCast env body co cont simplExprF' env (App fun arg) cont = simplExprF env fun $ ApplyTo NoDup arg env cont -simplExprF' env expr@(Lam _ _) cont +simplExprF' env expr@(Lam {}) cont = simplLam env zapped_bndrs body cont -- The main issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 @@ -898,15 +900,19 @@ simplExprF' env expr@(Lam _ _) cont n_args = countArgs cont -- NB: countArgs counts all the args (incl type args) -- and likewise drop counts all binders (incl type lambdas) - + zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyCoVar b = b - | otherwise = zapLamIdInfo b + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) - do { ty' <- simplCoercion env ty - ; rebuild env (Type ty') cont } + rebuild env (Type (substTy env ty)) cont + +simplExprF' env (Coercion co) cont + = ASSERT( contIsRhsOrArg cont ) + do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } simplExprF' env (Case scrut bndr _ alts) cont | sm_case_case (getMode env) @@ -941,13 +947,12 @@ simplType env ty new_ty = substTy env ty --------------------------------- -simplCoercion :: SimplEnv -> InType -> SimplM OutType --- The InType isn't *necessarily* a coercion, but it might be --- (in a type application, say) and optCoercion is a no-op on types +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = seqType new_co `seq` return new_co + = -- pprTrace "simplCoercion" (ppr co $$ ppr (getCvSubst env)) $ + seqCo new_co `seq` return new_co where - new_co = optCoercion (getTvSubst env) co + new_co = optCoercion (getCvSubst env) co \end{code} @@ -991,11 +996,11 @@ simplCast env body co0 cont0 where addCoerce co cont = add_coerce co (coercionKind co) cont - add_coerce _co (s1, k1) cont -- co :: ty~ty - | s1 `coreEqType` k1 = cont -- is a no-op + add_coerce _co (Pair s1 k1) cont -- co :: ty~ty + | s1 `eqType` k1 = cont -- is a no-op - add_coerce co1 (s1, _k2) (CoerceIt co2 cont) - | (_l1, t1) <- coercionKind co2 + add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont) + | (Pair _l1 t1) <- coercionKind co2 -- e |> (g1 :: S1~L) |> (g2 :: L~T1) -- ==> -- e, if S1=T1 @@ -1005,28 +1010,40 @@ simplCast env body co0 cont0 -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification - , s1 `coreEqType` t1 = cont -- The coerces cancel out - | otherwise = CoerceIt (mkTransCoercion co1 co2) cont + , s1 `eqType` t1 = cont -- The coerces cancel out + | otherwise = CoerceIt (mkTransCo co1 co2) cont - add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) + add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) -- (f |> g) ty ---> (f ty) |> (g @ ty) - -- This implements the PushT and PushC rules from the paper + -- This implements the PushT rule from the paper | Just (tyvar,_) <- splitForAllTy_maybe s1s2 - = let - (new_arg_ty, new_cast) - | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule - | otherwise = (ty', mkInstCoercion co ty') -- PushT rule - in - ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont) + = ASSERT( isTyVar tyvar ) + ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont) + where + new_cast = mkInstCo co arg_ty' + arg_ty' | isSimplified dup = arg_ty + | otherwise = substTy (arg_se `setInScope` env) arg_ty + +{- + add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont) + -- This implements the PushC rule from the paper + | Just (covar,_) <- splitForAllTy_maybe s1s2 + = ASSERT( isCoVar covar ) + ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont) where - ty' = substTy (arg_se `setInScope` env) arg_ty - new_arg_co = mkCsel1Coercion co `mkTransCoercion` - ty' `mkTransCoercion` - mkSymCoercion (mkCsel2Coercion co) - - add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) - | not (isTypeArg arg) -- This implements the Push rule from the paper - , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied + [co0, co1] = decomposeCo 2 co + [co00, co01] = decomposeCo 2 co0 + + arg_co' | isSimplified dup = arg_co + | otherwise = substCo (arg_se `setInScope` env) arg_co + new_arg_co = co00 `mkTransCo` + arg_co' `mkTransCo` + mkSymCo co01 +-} + + add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont) + | isFunTy s1s2 -- This implements the Push rule from the paper + , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg -- (e |> (g :: s1s2 ~ t1->t2)) f -- ===> -- (e (f |> (arg g :: t1~s1)) @@ -1047,7 +1064,7 @@ simplCast env body co0 cont0 -- t2 ~ s2 with left and right on the curried form: -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co - new_arg = mkCoerce (mkSymCoercion co1) arg' + new_arg = mkCoerce (mkSymCo co1) arg' arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg add_coerce co _ cont = CoerceIt co cont @@ -1120,10 +1137,15 @@ simplNonRecE :: SimplEnv -- First deal with type applications and type lets -- (/\a. e) (Type ty) and (let a = Type ty in e) simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont - = ASSERT( isTyCoVar bndr ) + = ASSERT( isTyVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } +simplNonRecE env bndr (Coercion co_arg, rhs_se) (bndrs, body) cont + = ASSERT( isCoVar bndr ) + do { co_arg' <- simplCoercion (rhs_se `setInScope` env) co_arg + ; simplLam (extendCvSubst env bndr co_arg') bndrs body cont } + simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont | preInlineUnconditionally env NotTopLevel bndr rhs = do { tick (PreInlineUnconditionally bndr) @@ -1135,7 +1157,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (StrictBind bndr bndrs body env cont) } | otherwise - = ASSERT( not (isTyCoVar bndr) ) + = ASSERT( not (isTyVar bndr) ) do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se @@ -1177,20 +1199,20 @@ simplNote env (CoreNote s) e cont simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var - | isTyCoVar var - = return (Type (substTyVar env var)) + | isTyVar var = return (Type (substTyVar env var)) + | isCoVar var = return (Coercion (substCoVar env var)) | otherwise = case substId env var of - DoneId var1 -> return (Var var1) - DoneEx e -> return e - ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e -simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplVarF env var cont +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplIdF env var cont = case substId env var of - DoneEx e -> simplExprF (zapSubstEnv env) e cont - ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 -> completeCall env var1 cont + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont + DoneId var1 -> completeCall env var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1266,13 +1288,19 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con res = mkApps (Var fun) (reverse rev_args) res_ty = exprType res cont_ty = contResultType env res_ty cont - co = mkUnsafeCoercion res_ty cont_ty - mk_coerce expr | cont_ty `coreEqType` res_ty = expr + co = mkUnsafeCo res_ty cont_ty + mk_coerce expr | cont_ty `eqType` res_ty = expr | otherwise = mkCoerce co expr -rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) - = do { ty' <- simplCoercion (se `setInScope` env) arg_ty - ; rebuildCall env (info `addArgTo` Type ty') cont } +rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) + = do { arg_ty' <- if isSimplified dup_flag then return arg_ty + else simplType (se `setInScope` env) arg_ty + ; rebuildCall env (info `addArgTo` Type arg_ty') cont } + +rebuildCall env info (ApplyTo dup_flag (Coercion arg_co) se cont) + = do { arg_co' <- if isSimplified dup_flag then return arg_co + else simplCoercion (se `setInScope` env) arg_co + ; rebuildCall env (info `addArgTo` Coercion arg_co') cont } rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) @@ -1280,7 +1308,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules | isSimplified dup_flag -- See Note [Avoid redundant simplification] = rebuildCall env (addArgTo info' arg) cont - | str -- Strict argument + | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg (StrictArg info' cci cont) @@ -1771,7 +1799,7 @@ improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq] , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } @@ -1834,7 +1862,7 @@ simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs) = go vs the_strs where go [] [] = [] - go (v:vs') strs | isTyCoVar v = v : go vs' strs + go (v:vs') strs | isTyVar v = v : go vs' strs go (v:vs') (str:strs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs @@ -1933,7 +1961,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont bind_args env' [] _ = return env' bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyCoVar b ) + = ASSERT( isTyVar b ) bind_args (extendTvSubst env' b ty) bs' args bind_args env' (b:bs') (arg : args) @@ -2151,7 +2179,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') | otherwise = bndrs' ++ [case_bndr_w_unf] abstract_over bndr - | isTyCoVar bndr = True -- Abstract over all type variables just in case + | isTyVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 3205542c8e..f9d02e5ab7 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -37,10 +37,10 @@ import CoreUtils ( exprType, eqExpr ) import PprCore ( pprRules ) import Type ( Type ) import TcType ( tcSplitTyConApp_maybe ) +import Coercion import CoreTidy ( tidyRules ) import Id import IdInfo ( SpecInfo( SpecInfo ) ) -import Var ( Var ) import VarEnv import VarSet import Name ( Name, NamedThing(..) ) @@ -56,7 +56,6 @@ import Util import Data.List \end{code} - Note [Overall plumbing for rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * After the desugarer: @@ -184,8 +183,9 @@ roughTopNames args = map roughTopName args roughTopName :: CoreExpr -> Maybe Name roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> Just (getName tc) - Nothing -> Nothing + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing roughTopName (App f _) = roughTopName f roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] , isDataConWorkId f || idArity f > 0 @@ -625,10 +625,7 @@ match :: RuleEnv -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match -match renv subst (Var v1) e2 - | Just subst <- match_var renv subst v1 e2 - = Just subst - +match renv subst (Var v1) e2 = match_var renv subst v1 e2 match renv subst (Note _ e1) e2 = match renv subst e1 e2 match renv subst e1 (Note _ e2) = match renv subst e1 e2 -- Ignore notes in both template and thing to be matched @@ -714,15 +711,29 @@ match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) match renv subst (Type ty1) (Type ty2) = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 match renv subst (Cast e1 co1) (Cast e2 co2) - = do { subst1 <- match_ty renv subst co1 co2 + = do { subst1 <- match_co renv subst co1 co2 ; match renv subst1 e1 e2 } -- Everything else fails match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ Nothing +------------- +match_co :: RuleEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst (CoVarCo cv) co + = match_var renv subst cv (Coercion co) +match_co _ _ co1 _ + = pprTrace "match_co baling out" (ppr co1) Nothing + +------------- rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv rnMatchBndr2 renv subst x1 x2 = renv { rv_lcl = rnBndr2 rn_env x1 x2 @@ -1038,6 +1049,7 @@ ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc ruleCheck _ (Var _) = emptyBag ruleCheck _ (Lit _) = emptyBag ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag ruleCheck env (App f a) = ruleCheckApp env (App f a) [] ruleCheck env (Note _ e) = ruleCheck env e ruleCheck env (Cast e _) = ruleCheck env e diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 4fa42046e8..5fc0226941 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -33,9 +33,9 @@ import CoreMonad import HscTypes ( ModGuts(..) ) import WwLib ( mkWorkerArgs ) import DataCon -import Coercion +import Coercion hiding( substTy, substCo ) import Rules -import Type hiding( substTy ) +import Type hiding ( substTy ) import Id import MkCore ( mkImpossibleExpr ) import Var @@ -50,6 +50,7 @@ import Demand import DmdAnal ( both ) import Serialized ( deserializeWithData ) import Util +import Pair import UniqSupply import Outputable import FastString @@ -699,6 +700,9 @@ scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v scSubstTy :: ScEnv -> Type -> Type scSubstTy env ty = substTy (sc_subst env) ty +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + zapScSubst :: ScEnv -> ScEnv zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } @@ -777,7 +781,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ varsToCoreExprs alt_bndrs - zap v | isTyCoVar v = v -- See NB2 above + zap v | isTyVar v = v -- See NB2 above | otherwise = zapIdOccInfo v @@ -997,11 +1001,12 @@ scExpr' env (Var v) = case scSubstId env v of e' -> scExpr (zapScSubst env) e' scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _ e@(Lit {}) = return (nullUsage, e) scExpr' env (Note n e) = do (usg,e') <- scExpr env e return (usg, Note n e') scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, Cast e' (scSubstTy env co)) + return (usg, Cast e' (scSubstCo env co)) scExpr' env e@(App _ _) = scApp env (collectArgs e) scExpr' env (Lam b e) = do let (env', b') = extendBndr env b (usg, e') <- scExpr env' e @@ -1047,7 +1052,7 @@ scExpr' env (Case scrut b ty alts) ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } scExpr' env (Let (NonRec bndr rhs) body) - | isTyCoVar bndr -- Type-lets may be created by doBeta + | isTyVar bndr -- Type-lets may be created by doBeta = scExpr' (extendScSubst env bndr rhs) body | otherwise @@ -1417,6 +1422,7 @@ calcSpecStrictness fn qvars pats dmd_env = go emptyVarEnv dmds pats go env ds (Type {} : pats) = go env ds pats + go env ds (Coercion {} : pats) = go env ds pats go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats go env _ _ = env @@ -1517,7 +1523,7 @@ callToPats env bndr_occs (con_env, args) -- at the call site -- See Note [Shadowing] at the top - (tvs, ids) = partition isTyCoVar qvars + (tvs, ids) = partition isTyVar qvars qvars' = tvs ++ ids -- Put the type variables first; the type of a term -- variable may mention a type variable @@ -1552,6 +1558,9 @@ argToPat :: ScEnv argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ = return (False, arg) + +argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ + = return (False, arg) argToPat env in_scope val_env (Note _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ @@ -1577,8 +1586,8 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ -} argToPat env in_scope val_env (Cast arg co) arg_occ - | isIdentityCoercion co -- Substitution in the SpecConstr itself - -- can lead to identity coercions + | isReflCo co -- Substitution in the SpecConstr itself + -- can lead to identity coercions = argToPat env in_scope val_env arg arg_occ | not (ignoreType env ty2) = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ @@ -1588,10 +1597,10 @@ argToPat env in_scope val_env (Cast arg co) arg_occ { -- Make a wild-card pattern for the coercion uniq <- getUniqueUs ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoKind ty1 ty2) - ; return (interesting, Cast arg' (mkTyVarTy co_var)) } } + co_var = mkCoVar co_name (mkCoType ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } where - (ty1, ty2) = coercionKind co + Pair ty1 ty2 = coercionKind co @@ -1699,7 +1708,7 @@ isValue env (Var v) -- as well, for let-bound constructors! isValue env (Lam b e) - | isTyCoVar b = case isValue env e of + | isTyVar b = case isValue env e of Just _ -> Just LambdaVal Nothing -> Nothing | otherwise = Just LambdaVal @@ -1734,6 +1743,7 @@ samePat (vs1, as1) (vs2, as2) same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Coercion {}) (Coercion {}) = True same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes same (Cast e1 _) e2 = same e1 e2 same e1 (Note _ e2) = same e1 e2 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 415378ac47..c192b3f60a 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -709,11 +709,12 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) ---------------- First the easy cases -------------------- specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs) +specExpr subst (Coercion co) = return (Coercion (CoreSubst.substCo subst co), emptyUDs) specExpr subst (Var v) = return (specVar subst v, emptyUDs) specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr subst (Cast e co) = do (e', uds) <- specExpr subst e - return ((Cast e' (CoreSubst.substTy subst co)), uds) + return ((Cast e' (CoreSubst.substCo subst co)), uds) specExpr subst (Note note body) = do (body', uds) <- specExpr subst body return (Note (specNote subst note) body', uds) @@ -1518,7 +1519,7 @@ instance Ord CallKey where cmp Nothing Nothing = EQ cmp Nothing (Just _) = LT cmp (Just _) Nothing = GT - cmp (Just t1) (Just t2) = tcCmpType t1 t2 + cmp (Just t1) (Just t2) = cmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 @@ -1603,7 +1604,9 @@ interestingDict :: CoreExpr -> Bool interestingDict (Var v) = hasSomeUnfolding (idUnfolding v) || isDataConWorkId v interestingDict (Type _) = False +interestingDict (Coercion _) = False interestingDict (App fn (Type _)) = interestingDict fn +interestingDict (App fn (Coercion _)) = interestingDict fn interestingDict (Note _ a) = interestingDict a interestingDict (Cast e _) = interestingDict e interestingDict _ = True diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 2059937e0b..fc7550fe01 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -18,8 +18,8 @@ import StgSyn import Type import TyCon +import MkId ( coercionTokenId ) import Id -import Var ( Var ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs) -- floated out a binding, in which case it will be approximate. consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id ) + = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) safe where safe = id_marked_caffy || not binding_is_caffy @@ -572,6 +572,10 @@ coreToStgArgs (Type _ : args) = do -- Type argument (args', fvs) <- coreToStgArgs args return (args', fvs) +coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder + = do { (args', fvs) <- coreToStgArgs args + ; return (StgVarArg coercionTokenId : args', fvs) } + coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, args_fvs) <- coreToStgArgs args (arg', arg_fvs, _escs) <- coreToStgExpr arg @@ -1124,7 +1128,7 @@ myCollectArgs expr go (Cast e _) as = go e as go (Note _ e) as = go e as go (Lam b e) as - | isTyCoVar b = go e as -- Note [Collect args] + | isTyVar b = go e as -- Note [Collect args] go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 3bce28148a..dd026eb80c 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -68,7 +68,8 @@ import FastString #if mingw32_TARGET_OS import Packages ( isDllName ) - +import Type ( typePrimRep ) +import TyCon ( PrimRep(..) ) #endif \end{code} @@ -118,8 +119,27 @@ isDllConApp this_pkg con args = isDllName this_pkg (dataConName con) || any is_dll_arg args where is_dll_arg ::StgArg -> Bool - is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v) + is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) + && isDllName this_pkg (idName v) is_dll_arg _ = False + +isAddrRep :: PrimRep -> Bool +-- True of machine adddresses; these are the things that don't +-- work across DLLs. +-- The key point here is that VoidRep comes out False, so that +-- a top level nullary GADT construtor is False for isDllConApp +-- data T a where +-- T1 :: T Int +-- gives +-- T1 :: forall a. (a~Int) -> T a +-- and hence the top-level binding +-- $WT1 :: T Int +-- $WT1 = T1 Int (Coercion (Refl Int)) +-- The coercion argument here gets VoidRep +isAddrRep AddrRep = True +isAddrRep PtrRep = True +isAddrRep _ = False + #else isDllConApp _ _ _ = False #endif diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 192d06f563..afa722fa8a 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -18,6 +18,7 @@ import StaticFlags ( opt_MaxWorkerArgs ) import Demand -- All of it import CoreSyn import PprCore +import Coercion ( isCoVarType ) import CoreUtils ( exprIsHNF, exprIsTrivial ) import CoreArity ( exprArity ) import DataCon ( dataConTyCon, dataConRepStrictness ) @@ -28,19 +29,20 @@ import Id ( Id, idType, idInlineActivation, setIdStrictness, idDemandInfo, idUnfolding, idDemandInfo_maybe, setIdDemandInfo ) -import Var ( Var ) +import Var ( Var, isTyVar ) import VarEnv import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, minusUFM, filterUFM ) -import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) +import Type ( isUnLiftedType, eqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) import Util ( mapAndUnzip, lengthIs, zipEqual ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec, isMarkedStrict ) import Maybes ( orElse, expectJust ) import Outputable +import Pair import Data.List import FastString \end{code} @@ -144,6 +146,7 @@ dmdAnal env dmd e dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit) dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co) dmdAnal env dmd (Var var) = (dmdTransform env var dmd, Var var) @@ -152,7 +155,7 @@ dmdAnal env dmd (Cast e co) = (dmd_ty, Cast e' co) where (dmd_ty, e') = dmdAnal env dmd' e - to_co = snd (coercionKind co) + to_co = pSnd (coercionKind co) dmd' | Just (tc, _) <- splitTyConApp_maybe to_co , isRecursiveTyCon tc = evalDmd @@ -173,6 +176,11 @@ dmdAnal env dmd (App fun (Type ty)) where (fun_ty, fun') = dmdAnal env dmd fun +dmdAnal sigs dmd (App fun (Coercion co)) + = (fun_ty, App fun' (Coercion co)) + where + (fun_ty, fun') = dmdAnal sigs dmd fun + -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) dmdAnal env dmd (App fun arg) -- Non-type arguments @@ -184,7 +192,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments (res_ty `bothType` arg_ty, App fun' arg') dmdAnal env dmd (Lam var body) - | isTyCoVar var + | isTyVar var = let (body_ty, body') = dmdAnal env dmd body in @@ -328,7 +336,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs) -- ; print len } io_hack_reqd = con == DataAlt unboxedPairDataCon && - idType (head bndrs) `coreEqType` realWorldStatePrimTy + idType (head bndrs) `eqType` realWorldStatePrimTy in (final_alt_ty, (con, bndrs', rhs')) @@ -838,7 +846,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var) -- The returned var is annotated with demand info -- No effect on the argument demands annotateBndr dmd_ty@(DmdType fv ds res) var - | isTyCoVar var = (dmd_ty, var) + | isTyVar var = (dmd_ty, var) | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd) where (fv', dmd) = removeFV fv var res @@ -888,10 +896,15 @@ removeFV fv id res = (fv', zapUnlifted id dmd) zapUnlifted :: Id -> Demand -> Demand -- For unlifted-type variables, we are only -- interested in Bot/Abs/Box Abs -zapUnlifted _ Bot = Bot -zapUnlifted _ Abs = Abs -zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd - | otherwise = dmd +zapUnlifted id dmd + = case dmd of + _ | isCoVarType ty -> lazyDmd -- For coercions, ignore str/abs totally + Bot -> Bot + Abs -> Abs + _ | isUnLiftedType ty -> lazyDmd -- For unlifted types, ignore strictness + | otherwise -> dmd + where + ty = idType id \end{code} Note [Lamba-bound unfoldings] diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 5cf5e92692..ac10b1b773 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -100,6 +100,7 @@ matching by looking for strict arguments of the correct type. wwExpr :: CoreExpr -> UniqSM CoreExpr wwExpr e@(Type {}) = return e +wwExpr e@(Coercion {}) = return e wwExpr e@(Lit {}) = return e wwExpr e@(Var {}) = return e diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index e7d0edf0f8..391c07c089 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -23,10 +23,9 @@ import MkId ( realWorldPrimId, voidArgId, import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) import Type -import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe ) +import Coercion ( mkSymCo, splitNewTypeRepCo_maybe ) import BasicTypes ( Boxity(..) ) import Literal ( absentLiteralOf ) -import Var ( Var ) import UniqSupply import Unique import Util ( zipWithEqual ) @@ -244,7 +243,7 @@ mkWWargs subst fun_ty arg_info = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs subst rep_ty arg_info ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCoercion co), + \e -> Cast (wrap_fn_args e) (mkSymCo co), \e -> work_fn_args (Cast e co), res_ty) } @@ -271,7 +270,7 @@ mkWWargs subst fun_ty arg_info <- mkWWargs subst fun_ty' arg_info' ; return (id : wrap_args, Lam id . wrap_fn_args, - work_fn_args . (`App` Var id), + work_fn_args . (`App` varToCoreExpr id), res_ty) } | otherwise @@ -291,18 +290,12 @@ mk_wrap_arg uniq ty dmd one_shot Note [Freshen type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -mkWWargs may be given a type like (a~b) => <blah> -Which really means forall (co:a~b). <blah> -Because the name of the coercion variable, 'co', isn't mentioned in <blah>, -nested coercion foralls may all use the same variable; and sometimes do -see Var.mkWildCoVar. - -However, when we do a worker/wrapper split, we must not use shadowed names, +Wen we do a worker/wrapper split, we must not use shadowed names, else we'll get - f = /\ co /\co. fw co co -which is obviously wrong. Actually, the same is true of type variables, which -can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a). -But type variables *are* mentioned in <blah>, so we must substitute. + f = /\ a /\a. fw a a +which is obviously wrong. Type variables can can in principle shadow, +within a type (e.g. forall a. a -> forall a. a->a). But type +variables *are* mentioned in <blah>, so we must substitute. That's why we carry the TvSubst through mkWWargs @@ -339,7 +332,7 @@ mkWWstr (arg : args) = do -- brings into scope wrap_arg (via lets) mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one arg - | isTyCoVar arg + | isTyVar arg = return ([arg], nop_fn, nop_fn) | otherwise @@ -525,7 +518,7 @@ mk_absent_let arg | Just (tc, _) <- splitTyConApp_maybe arg_ty , Just lit <- absentLiteralOf tc = Just (Let (NonRec arg (Lit lit))) - | arg_ty `coreEqType` realWorldStatePrimTy + | arg_ty `eqType` realWorldStatePrimTy = Just (Let (NonRec arg (Var realWorldPrimId))) | otherwise = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty ) diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 45584d9b41..c41806a5ec 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -196,17 +196,11 @@ addFamInstLoc famInst thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc famInst -\end{code} - -\begin{code} tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv) -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) tcGetFamInstEnvs = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) - } - - + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index bbdf21bc3c..5474cfa3cb 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -46,11 +46,10 @@ import TcMType import TcType import Class import Unify -import Coercion import HscTypes import Id import Name -import Var +import Var ( Var, TyVar, EvVar, varType, setVarType ) import VarEnv import VarSet import PrelNames @@ -212,11 +211,8 @@ instCallConstraints _ [] = return idHsWrapper instCallConstraints origin (EqPred ty1 ty2 : preds) -- Try short-cut = do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2) - ; coi <- unifyType ty1 ty2 + ; co <- unifyType ty1 ty2 ; co_fn <- instCallConstraints origin preds - ; let co = case coi of - IdCo ty -> ty - ACo co -> co ; return (co_fn <.> WpEvApp (EvCoercion co)) } instCallConstraints origin (pred : preds) @@ -605,4 +601,4 @@ substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty) substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids) substSkolemInfo _ info = info -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index ae4a1e8761..de236e767c 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -41,17 +41,17 @@ import Control.Monad \begin{code} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr -> TcRhoType -- Expected type of whole proc expression - -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI) + -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion) tcProc pat cmd exp_ty = newArrowScope $ do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ + ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ tcCmdTop cmd_env cmd [] res_ty - ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty)) - ; return (pat', cmd', res_coi) } + ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty)) + ; return (pat', cmd', res_coi) } \end{code} @@ -187,8 +187,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats cmd_stk $ - tc_grhss grhss res_ty + tcPats LambdaExpr pats cmd_stk $ + tc_grhss grhss res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') ; return (HsLam (MatchGroup [match'] res_ty)) @@ -249,7 +249,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) e_res_ty -- Check expr - ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ + ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ escapeArrowScope (tcMonoExpr expr e_ty) -- OK, now we are in a position to unscramble @@ -279,7 +279,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- Check that it has the right shape: -- ((w,s1) .. sn) -- where the si do not mention w - ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv && + ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) (badFormFun i tup_ty') diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8a6a3b7fc0..3a30f9b5a1 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -854,7 +854,7 @@ unifyCtxts (sig1 : sigs) -- where F is a type function and (F a ~ [a]) -- Then unification might succeed with a coercion. But it's much -- much simpler to require that such signatures have identical contexts - checkTc (all isIdentityCoI cois) + checkTc (all isReflCo cois) (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) } \end{code} diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 59cc736083..44cff5eb93 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -8,12 +8,13 @@ module TcCanonical( #include "HsVersions.h" import BasicTypes -import Type +import Id ( evVarPred ) +import TcErrors import TcRnTypes import FunDeps import qualified TcMType as TcM import TcType -import TcErrors +import Type import Coercion import Class import TyCon @@ -112,29 +113,29 @@ flatten ctxt ty -- We can tell if ty' is function-free by -- whether there are any floated constraints ; if isEmptyCCan ccs then - return (ty, ty, emptyCCan) + return (ty, mkReflCo ty, emptyCCan) else return (xi, co, ccs) } flatten _ v@(TyVarTy _) - = return (v, v, emptyCCan) + = return (v, mkReflCo v, emptyCCan) flatten ctxt (AppTy ty1 ty2) = do { (xi1,co1,c1) <- flatten ctxt ty1 ; (xi2,co2,c2) <- flatten ctxt ty2 - ; return (mkAppTy xi1 xi2, mkAppCoercion co1 co2, c1 `andCCan` c2) } + ; return (mkAppTy xi1 xi2, mkAppCo co1 co2, c1 `andCCan` c2) } flatten ctxt (FunTy ty1 ty2) = do { (xi1,co1,c1) <- flatten ctxt ty1 ; (xi2,co2,c2) <- flatten ctxt ty2 - ; return (mkFunTy xi1 xi2, mkFunCoercion co1 co2, c1 `andCCan` c2) } + ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, c1 `andCCan` c2) } flatten fl (TyConApp tc tys) -- For a normal type constructor or data family application, we just -- recursively flatten the arguments. | not (isSynFamilyTyCon tc) = do { (xis,cos,ccs) <- flattenMany fl tys - ; return (mkTyConApp tc xis, mkTyConCoercion tc cos, ccs) } + ; return (mkTyConApp tc xis, mkTyConAppCo tc cos, ccs) } -- Otherwise, it's a type function application, and we have to -- flatten it away as well, and generate a new given equality constraint @@ -148,7 +149,7 @@ flatten fl (TyConApp tc tys) -- in which case the remaining arguments should -- be dealt with by AppTys fam_ty = mkTyConApp tc xi_args - fam_co = fam_ty -- identity + fam_co = mkReflCo fam_ty -- identity ; (ret_co, rhs_var, ct) <- if isGiven fl then @@ -159,7 +160,7 @@ flatten fl (TyConApp tc tys) , cc_fun = tc , cc_tyargs = xi_args , cc_rhs = rhs_var } - ; return $ (mkCoVarCoercion cv, rhs_var, ct) } + ; return $ (mkCoVarCo cv, rhs_var, ct) } else -- Derived or Wanted: make a new *unification* flatten variable do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) ; cv <- newCoVar fam_ty rhs_var @@ -169,11 +170,13 @@ flatten fl (TyConApp tc tys) , cc_fun = tc , cc_tyargs = xi_args , cc_rhs = rhs_var } - ; return $ (mkCoVarCoercion cv, rhs_var, ct) } + ; return $ (mkCoVarCo cv, rhs_var, ct) } ; return ( foldl AppTy rhs_var xi_rest - , foldl AppTy (mkSymCoercion ret_co - `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest + , foldl mkAppCo + (mkSymCo ret_co + `mkTransCo` mkTyConAppCo tc cos_args) + cos_rest , ccs `extendCCans` ct) } @@ -193,22 +196,20 @@ flatten ctxt ty@(ForAllTy {}) tv_set = mkVarSet tvs ; unless (isEmptyBag bad_eqs) (flattenForAllErrorTcS ctxt ty bad_eqs) - ; return (mkForAllTys tvs rho', mkForAllTys tvs co, ccs) } + ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs) } --------------- flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts) flattenPred ctxt (ClassP cls tys) = do { (tys', cos, ccs) <- flattenMany ctxt tys - ; return (ClassP cls tys', mkClassPPredCo cls cos, ccs) } + ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) } flattenPred ctxt (IParam nm ty) = do { (ty', co, ccs) <- flatten ctxt ty - ; return (IParam nm ty', mkIParamPredCo nm co, ccs) } --- TODO: Handling of coercions between EqPreds must be revisited once the New Coercion API is ready! + ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) } flattenPred ctxt (EqPred ty1 ty2) = do { (ty1', co1, ccs1) <- flatten ctxt ty1 ; (ty2', co2, ccs2) <- flatten ctxt ty2 - ; return (EqPred ty1' ty2', mkEqPredCo co1 co2, ccs1 `andCCan` ccs2) } - + ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) } \end{code} %************************************************************************ @@ -249,14 +250,14 @@ canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList canClassToWorkList fl v cn tys = do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys ; let no_flattening_happened = isEmptyCCan ccs - dict_co = mkTyConCoercion (classTyCon cn) cos + dict_co = mkTyConAppCo (classTyCon cn) cos ; v_new <- if no_flattening_happened then return v else if isGiven fl then return v -- The cos are all identities if fl=Given, -- hence nothing to do else do { v' <- newDictVar cn xis -- D xis ; when (isWanted fl) $ setDictBind v (EvCast v' dict_co) - ; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co)) + ; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCo dict_co)) -- NB: No more setting evidence for derived now ; return v' } @@ -391,9 +392,9 @@ canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2 canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts canEq fl cv ty1 ty2 - | tcEqType ty1 ty2 -- Dealing with equality here avoids + | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = do { when (isWanted fl) (setCoBind cv ty1) + = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1)) ; return emptyCCan } -- If one side is a variable, orient and flatten, @@ -407,47 +408,6 @@ canEq fl cv ty1 ty2@(TyVarTy {}) ; canEqLeaf untch fl cv (classify ty1) (classify ty2) } -- NB: don't use VarCls directly because tv1 or tv2 may be scolems! -canEq fl cv (TyConApp fn tys) ty2 - | isSynFamilyTyCon fn, length tys == tyConArity fn - = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) } -canEq fl cv ty1 (TyConApp fn tys) - | isSynFamilyTyCon fn, length tys == tyConArity fn - = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) } - -canEq fl cv s1 s2 - | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe s1, - Just (t2a,t2b,t2c) <- splitCoPredTy_maybe s2 - = do { (v1,v2,v3) - <- if isWanted fl then -- Wanted - do { v1 <- newCoVar t1a t2a - ; v2 <- newCoVar t1b t2b - ; v3 <- newCoVar t1c t2c - ; let res_co = mkCoPredCo (mkCoVarCoercion v1) - (mkCoVarCoercion v2) (mkCoVarCoercion v3) - ; setCoBind cv res_co - ; return (v1,v2,v3) } - else if isGiven fl then -- Given - let co_orig = mkCoVarCoercion cv - coa = mkCsel1Coercion co_orig - cob = mkCsel2Coercion co_orig - coc = mkCselRCoercion co_orig - in do { v1 <- newGivenCoVar t1a t2a coa - ; v2 <- newGivenCoVar t1b t2b cob - ; v3 <- newGivenCoVar t1c t2c coc - ; return (v1,v2,v3) } - else -- Derived - do { v1 <- newDerivedId (EqPred t1a t2a) - ; v2 <- newDerivedId (EqPred t1b t2b) - ; v3 <- newDerivedId (EqPred t1c t2c) - ; return (v1,v2,v3) } - ; cc1 <- canEq fl v1 t1a t2a - ; cc2 <- canEq fl v2 t1b t2b - ; cc3 <- canEq fl v3 t1c t2c - ; return (cc1 `andCCan` cc2 `andCCan` cc3) } - - -- Split up an equality between function types into two equalities. canEq fl cv (FunTy s1 t1) (FunTy s2 t2) = do { (argv, resv) <- @@ -455,11 +415,11 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2) do { argv <- newCoVar s1 s2 ; resv <- newCoVar t1 t2 ; setCoBind cv $ - mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv) + mkFunCo (mkCoVarCo argv) (mkCoVarCo resv) ; return (argv,resv) } else if isGiven fl then - let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv) + let [arg,res] = decomposeCo 2 (mkCoVarCo cv) in do { argv <- newGivenCoVar s1 s2 arg ; resv <- newGivenCoVar t1 t2 res ; return (argv,resv) } @@ -473,33 +433,17 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2) ; cc2 <- canEq fl resv t1 t2 ; return (cc1 `andCCan` cc2) } -canEq fl cv (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) - | n1 == n2 - = if isWanted fl then - do { v <- newCoVar t1 t2 - ; setCoBind cv $ mkIParamPredCo n1 (mkCoVarCoercion cv) - ; canEq fl v t1 t2 } - else return emptyCCan -- DV: How to decompose given IP coercions? - -canEq fl cv (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) - | c1 == c2 - = if isWanted fl then - do { vs <- zipWithM newCoVar tys1 tys2 - ; setCoBind cv $ mkClassPPredCo c1 (map mkCoVarCoercion vs) - ; andCCans <$> zipWith3M (canEq fl) vs tys1 tys2 - } - else return emptyCCan - -- How to decompose given dictionary (and implicit parameter) coercions? - -- You may think that the following is right: - -- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) - -- in zipWith3M newGivOrDerCoVar tys1 tys2 cos - -- But this assumes that the coercion is a type constructor-based - -- coercion, and not a PredTy (ClassP cn cos) coercion. So we chose - -- to not decompose these coercions. We have to get back to this - -- when we clean up the Coercion API. +canEq fl cv (TyConApp fn tys) ty2 + | isSynFamilyTyCon fn, length tys == tyConArity fn + = do { untch <- getUntouchables + ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) } +canEq fl cv ty1 (TyConApp fn tys) + | isSynFamilyTyCon fn, length tys == tyConArity fn + = do { untch <- getUntouchables + ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) } canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | isAlgTyCon tc1 && isAlgTyCon tc2 + | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 , tc1 == tc2 , length tys1 == length tys2 = -- Generate equalities for each of the corresponding arguments @@ -507,11 +451,11 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) <- if isWanted fl then do { argsv <- zipWithM newCoVar tys1 tys2 ; setCoBind cv $ - mkTyConCoercion tc1 (map mkCoVarCoercion argsv) + mkTyConAppCo tc1 (map mkCoVarCo argsv) ; return argsv } else if isGiven fl then - let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) + let cos = decomposeCo (length tys1) (mkCoVarCo cv) in zipWith3M newGivenCoVar tys1 tys2 cos else -- Derived @@ -524,28 +468,24 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) canEq fl cv ty1 ty2 | Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { (cv1,cv2) <- - if isWanted fl - then do { cv1 <- newCoVar s1 s2 - ; cv2 <- newCoVar t1 t2 - ; setCoBind cv $ - mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2) - ; return (cv1,cv2) } - - else if isGiven fl then - let co1 = mkLeftCoercion $ mkCoVarCoercion cv - co2 = mkRightCoercion $ mkCoVarCoercion cv - in do { cv1 <- newGivenCoVar s1 s2 co1 - ; cv2 <- newGivenCoVar t1 t2 co2 - ; return (cv1,cv2) } - else -- Derived - do { cv1 <- newDerivedId (EqPred s1 s2) - ; cv2 <- newDerivedId (EqPred t1 t2) - ; return (cv1,cv2) } - - ; cc1 <- canEq fl cv1 s1 s2 - ; cc2 <- canEq fl cv2 t1 t2 - ; return (cc1 `andCCan` cc2) } + = if isWanted fl + then do { cv1 <- newCoVar s1 s2 + ; cv2 <- newCoVar t1 t2 + ; setCoBind cv $ + mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2) + ; cc1 <- canEq fl cv1 s1 s2 + ; cc2 <- canEq fl cv2 t1 t2 + ; return (cc1 `andCCan` cc2) } + + else if isDerived fl + then do { cv1 <- newDerivedId (EqPred s1 s2) + ; cv2 <- newDerivedId (EqPred t1 t2) + ; cc1 <- canEq fl cv1 s1 s2 + ; cc2 <- canEq fl cv2 t1 t2 + ; return (cc1 `andCCan` cc2) } + + else return emptyCCan -- We cannot decompose given applications + -- because we no longer have 'left' and 'right' canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2, @@ -749,10 +689,10 @@ canEqLeaf _untch fl cv cls1 cls2 | cls1 `re_orient` cls2 = do { cv' <- if isWanted fl then do { cv' <- newCoVar s2 s1 - ; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv') + ; setCoBind cv $ mkSymCo (mkCoVarCo cv') ; return cv' } else if isGiven fl then - newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv)) + newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv)) else -- Derived newDerivedId (EqPred s2 s1) ; canEqLeafOriented fl cv' cls2 s1 } @@ -790,11 +730,11 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1 do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2 -- cv' : F xis ~ xi2 ; let -- fun_co :: F xis1 ~ F tys1 - fun_co = mkTyConCoercion fn cos1 + fun_co = mkTyConAppCo fn cos1 -- want_co :: F tys1 ~ s2 - want_co = mkSymCoercion fun_co - `mkTransCoercion` mkCoVarCoercion cv' - `mkTransCoercion` co2 + want_co = mkSymCo fun_co + `mkTransCo` mkCoVarCo cv' + `mkTransCo` co2 ; setCoBind cv want_co ; return cv' } else -- Derived @@ -834,7 +774,7 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2 else if isGiven fl then return cv else if isWanted fl then do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2 - ; setCoBind cv (mkCoVarCoercion cv' `mkTransCoercion` co) + ; setCoBind cv (mkCoVarCo cv' `mkTransCo` co) ; return cv' } else -- Derived newDerivedId (EqPred (mkTyVarTy tv) xi2') @@ -898,7 +838,7 @@ expandAway tv (FunTy ty1 ty2) expandAway tv ty@(ForAllTy {}) = let (tvs,rho) = splitForAllTys ty tvs_knds = map tyVarKind tvs - in if tv `elemVarSet` tyVarsOfTypes tvs_knds then + in if tv `elemVarSet` tyVarsOfTypes tvs_knds then -- Can't expand away the kinds unless we create -- fresh variables which we don't want to do at this point. Nothing @@ -1064,8 +1004,8 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc do_one subst (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) - = do { let sty1 = substTy subst ty1 - sty2 = substTy subst ty2 + = do { let sty1 = Type.substTy subst ty1 + sty2 = Type.substTy subst ty2 ; ev <- newCoVar sty1 sty2 ; return (i, mkEvVarX ev fl') } @@ -1077,8 +1017,8 @@ rewriteDictParams param_eqs tys where do_one :: Type -> Int -> (Type,Coercion) do_one ty n = case lookup n param_eqs of - Just wev -> (get_fst_ty wev, mkCoVarCoercion (evVarOf wev)) - Nothing -> (ty,ty) -- Identity + Just wev -> (get_fst_ty wev, mkCoVarCo (evVarOf wev)) + Nothing -> (ty, mkReflCo ty) -- Identity get_fst_ty wev = case evVarOfPred wev of EqPred ty1 _ -> ty1 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2988f08a38..195eb994b6 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1294,7 +1294,7 @@ inferInstanceContexts oflag infer_specs ; let tv_set = mkVarSet tyvars weird_preds = [pred | pred <- deriv_rhs - , not (tyVarsOfPred pred `subVarSet` tv_set)] + , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds ; theta <- simplifyDeriv orig tyvars deriv_rhs @@ -1423,14 +1423,12 @@ genInst standalone_deriv oflag where inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) + Just co_con -> mkAxInstCo co_con rep_tc_args Nothing -> id_co -- Not a family => rep_tycon = main tycon - co2 = case newTyConCo_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) - Nothing -> id_co -- The newtype is transparent; no need for a cast - co = co1 `mkTransCoI` co2 - id_co = IdCo (mkTyConApp rep_tycon rep_tc_args) + co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args + co = co1 `mkTransCo` co2 + id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) -- Example: newtype instance N [a] = N1 (Tree a) -- deriving instance Eq b => Eq (N [(b,b)]) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 354e4b238a..f1d14a5c95 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -626,7 +626,8 @@ data InstBindings a -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. - CoercionI -- The coercion maps from newtype to the representation type + -- BAY* : should this be a CoAxiom? + Coercion -- The coercion maps from newtype to the representation type -- (mentioning type variables bound by the forall'd iSpec variables) -- E.g. newtype instance N [a] = N1 (Tree a) -- co : N [a] ~ Tree a @@ -640,7 +641,7 @@ data InstBindings a pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = hang (ptext (sLit "instance")) 2 (sep [ ifPprDebug (pprForAll tvs) - , pprThetaArrow theta, ppr tau + , pprThetaArrowTy theta, ppr tau , ptext (sLit "where")]) where (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info)) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index f714943227..9cbd47bcd8 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -15,14 +15,12 @@ import TcMType import TcSMonad import TcType import TypeRep - import Inst import InstEnv - import TyCon import Name import NameEnv -import Id ( idType ) +import Id ( idType, evVarPred ) import Var import VarSet import VarEnv @@ -222,7 +220,7 @@ pprWithArising ev_vars where first_loc = evVarX (head ev_vars) ppr_one (EvVarX v loc) - = parens (pprPred (evVarPred v)) <+> pprArisingAt loc + = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc addErrorReport :: ReportErrCtxt -> SDoc -> TcM () addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) @@ -299,8 +297,8 @@ getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp ty1 ty2 -- If the types in the error message are the same as the types we are unifying, -- don't add the extra expected/actual message - | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty - | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty + | act `eqType` ty1 && exp `eqType` ty2 = empty + | exp `eqType` ty1 && act `eqType` ty2 = empty | otherwise = mkExpectedActualMsg act exp getWantedEqExtra orig _ _ = pprArising orig @@ -563,7 +561,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) mk_overlap_msg (matches, unifiers) = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") - <+> pprPred pred) + <+> pprPredTy pred) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] , if not (isSingleton matches) @@ -572,7 +570,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) else -- One match, plus some unifiers ASSERT( not (null unifiers) ) parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), + quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), ptext (sLit "when compiling the other instance declarations")])] where diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 6bb0820823..2236740407 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -286,8 +286,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; co_res <- unifyType op_res_ty res_ty ; op_id <- tcLookupId op_name ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id)) - ; return $ mkHsWrapCoI co_res $ - OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' } + ; return $ mkHsWrapCo co_res $ + OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' } | otherwise = do { traceTc "Non Application rule" (ppr op) @@ -295,8 +295,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty ; co_res <- unifyType op_res_ty res_ty ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys - ; return $ mkHsWrapCoI co_res $ - OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' } + ; return $ mkHsWrapCo co_res $ + OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr @@ -306,8 +306,8 @@ tcExpr (SectionR op arg2) res_ty ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; return $ mkHsWrapCoI co_res $ - SectionR (mkLHsWrapCoI co_fn op') arg2' } + ; return $ mkHsWrapCo co_res $ + SectionR (mkLHsWrapCo co_fn op') arg2' } tcExpr (SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op @@ -318,15 +318,15 @@ tcExpr (SectionL arg1 op) res_ty ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty ; arg1' <- tcArg op (arg1, arg1_ty, 1) - ; return $ mkHsWrapCoI co_res $ - SectionL arg1' (mkLHsWrapCoI co_fn op') } + ; return $ mkHsWrapCo co_res $ + SectionL arg1' (mkLHsWrapCo co_fn op') } tcExpr (ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args = do { let tup_tc = tupleTyCon boxity (length tup_args) ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) @@ -345,19 +345,19 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } tcExpr (ExplicitList _ exprs) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') } + ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') } + ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty \end{code} @@ -420,7 +420,7 @@ tcExpr (HsDo do_or_lc stmts body _) res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } + ; return $ mkHsWrapCo coi (HsProc pat' cmd') } tcExpr e@(HsArrApp _ _ _ _ _) _ = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), @@ -467,7 +467,7 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty ; co_res <- unifyType actual_res_ty res_ty ; rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; return $ mkHsWrapCoI co_res $ + ; return $ mkHsWrapCo co_res $ RecordCon (L loc con_id) con_expr rbinds' } \end{code} @@ -603,7 +603,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- Take apart a representative constructor con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1 + (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 con1_flds = dataConFieldLabels con1 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) @@ -641,10 +641,10 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys - ; let rec_res_ty = substTy result_inst_env con1_res_ty - con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys + ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty + con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys - scrut_ty = substTy scrut_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty ; co_res <- unifyType rec_res_ty res_ty @@ -659,11 +659,11 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- Step 7: make a cast for the scrutinee, in the case that it's from a type family ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon - = WpCast $ mkTyConApp co_con scrut_inst_tys + = WpCast $ mkAxInstCo co_con scrut_inst_tys | otherwise = idHsWrapper -- Phew! - ; return $ mkHsWrapCoI co_res $ + ; return $ mkHsWrapCo co_res $ RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' relevant_cons scrut_inst_tys result_inst_tys } where @@ -703,7 +703,7 @@ tcExpr (ArithSeq _ seq@(From expr)) res_ty ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) enumFromName elt_ty - ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) } + ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) } tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty @@ -711,7 +711,7 @@ tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) enumFromThenName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq enum_from_then (FromThen expr1' expr2')) } tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty @@ -720,7 +720,7 @@ tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) enumFromToName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty @@ -730,7 +730,7 @@ tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty @@ -739,7 +739,7 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (PArrSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty @@ -749,7 +749,7 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ _) _ @@ -827,8 +827,8 @@ tcApp fun args res_ty ; args1 <- tcArgs fun args expected_arg_tys -- Assemble the result - ; let fun2 = mkLHsWrapCoI co_fun fun1 - app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1) + ; let fun2 = mkLHsWrapCo co_fun fun1 + app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1) ; return (unLoc app) } @@ -850,7 +850,7 @@ tcInferApp fun args ; (co_fun, expected_arg_tys, actual_res_ty) <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau ; args1 <- tcArgs fun args expected_arg_tys - ; let fun2 = mkLHsWrapCoI co_fun fun1 + ; let fun2 = mkLHsWrapCo co_fun fun1 app = foldl mkHsApp fun2 args1 ; return (unLoc app, actual_res_ty) } @@ -899,7 +899,7 @@ tcTupArgs args tys ---------------- unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType - -> TcM (CoercionI, [TcSigmaType], TcRhoType) + -> TcM (Coercion, [TcSigmaType], TcRhoType) -- A wrapper for matchExpectedFunTys unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty where @@ -1010,7 +1010,7 @@ instantiateOuter orig id ; let theta' = substTheta subst theta ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta')) ; wrap <- instCall orig tys theta' - ; return (mkHsWrap wrap (HsVar id), substTy subst tau) } + ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) } where (tvs, theta, tau) = tcSplitSigmaTy (idType id) \end{code} @@ -1134,7 +1134,7 @@ tcTagToEnum loc fun_name arg res_ty ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) rep_ty = mkTyConApp rep_tc rep_args - ; return (mkHsWrapCoI coi $ HsApp fun' arg') } + ; return (mkHsWrapCo coi $ HsApp fun' arg') } where doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] @@ -1142,18 +1142,18 @@ tcTagToEnum loc fun_name arg res_ty doc3 = ptext (sLit "No family instance for this type") get_rep_ty :: TcType -> TyCon -> [TcType] - -> TcM (CoercionI, TyCon, [TcType]) + -> TcM (Coercion, TyCon, [TcType]) -- Converts a family type (eg F [a]) to its rep type (eg FList a) -- and returns a coercion between the two get_rep_ty ty tc tc_args | not (isFamilyTyCon tc) - = return (IdCo ty, tc, tc_args) + = return (mkReflCo ty, tc, tc_args) | otherwise = do { mb_fam <- tcLookupFamInst tc tc_args ; case mb_fam of Nothing -> failWithTc (tagToEnumError ty doc3) Just (rep_tc, rep_args) - -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args)) + -> return ( mkSymCo (mkAxInstCo co_tc rep_args) , rep_tc, rep_args ) where co_tc = expectJust "tcTagToEnum" $ diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c04cf4bc3..272199999b 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -50,7 +50,6 @@ import TcType import TysPrim import TysWiredIn import Type -import Var( TyVar ) import TypeRep import VarSet import State @@ -1831,7 +1830,7 @@ assoc_ty_id cls_str _ tbl ty text "for primitive type" <+> ppr ty) | otherwise = head res where - res = [id | (ty',id) <- tbl, ty `tcEqType` ty'] + res = [id | (ty',id) <- tbl, ty `eqType` ty'] ----------------------------------------------------------------------- diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 122b743742..06cbe33daf 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -35,6 +35,7 @@ import TcRnMonad import PrelNames import TcType import TcMType +import Coercion import TysPrim import TysWiredIn import DataCon @@ -43,14 +44,15 @@ import NameSet import Var import VarSet import VarEnv +import DynFlags( DynFlag(..) ) import Literal import BasicTypes import Maybes import SrcLoc -import DynFlags( DynFlag(..) ) import Bag import FastString import Outputable +import Data.Traversable( traverse ) \end{code} \begin{code} @@ -676,7 +678,7 @@ zonkCoFn env WpHole = return (env, WpHole) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co +zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } @@ -1004,7 +1006,6 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) zonk_it env v | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } - | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} @@ -1034,10 +1035,10 @@ zonkVect env (HsVect v (Just e)) zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) -zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co +zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co ; return (EvCoercion co') } zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcTypeToType env co + do { co' <- zonkTcCoToCo env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) zonkEvTerm env (EvDFunApp df tys tms) @@ -1112,4 +1113,28 @@ zonkTypeZapping ty zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } + +zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +zonkTcCoToCo env co + = go co + where + go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) + go (Refl ty) = do { ty' <- zonkTcTypeToType env ty + ; return (Refl ty') } + go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') } + go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') } + go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkAppCo co1' co2') } + go (PredCo pco) = do { pco' <- go `traverse` pco; return (mkPredCo pco') } + go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1 + ; t2' <- zonkTcTypeToType env t2 + ; return (mkUnsafeCo t1' t2') } + go (SymCo co) = do { co' <- go co; return (mkSymCo co') } + go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') } + go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTransCo co1' co2') } + go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty + ; return (mkInstCo co' ty') } + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkForAllCo tv co') } \end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 71eb55ed6c..a58761b1af 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -857,7 +857,7 @@ tcPatSig :: UserTypeCtxt [(Name, TcType)], -- The new bit of type environment, binding -- the scoped type variables HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty + -- Of shape: res_ty ~ sig_ty tcPatSig ctxt sig res_ty = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig -- sig_tvs are the type variables free in 'sig', @@ -869,8 +869,7 @@ tcPatSig ctxt sig res_ty -- and hence is rigid, so use it to zap the res_ty wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - - } else do { + } else do { -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables @@ -893,20 +892,20 @@ tcPatSig ctxt sig res_ty ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs + ; sig_tvs' <- tcInstSigTyVars sig_tvs ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty sig_tv_tys' = mkTyVarTys sig_tvs' - ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' + ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' -- Check that each is bound to a distinct type variable, -- and one that is not already in scope - ; binds_in_scope <- getScopedTyVarBinds + ; binds_in_scope <- getScopedTyVarBinds ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' ; check binds_in_scope tv_binds -- Phew! - ; return (sig_ty', tv_binds, wrap) - } } + ; return (sig_ty', tv_binds, wrap) + } } where check _ [] = return () check in_scope ((n,ty):rest) = do { check_one in_scope n ty @@ -917,7 +916,7 @@ tcPatSig ctxt sig res_ty -- Must not bind to the same type variable -- as some other in-scope type variable where - dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty] + dups = [n' | (n',ty') <- in_scope, eqType ty' ty] \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3bb27a78de..503812a3b8 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -16,22 +16,24 @@ import TcPat( addInlinePrags ) import TcRnMonad import TcMType import TcType +import BuildTyCl import Inst import InstEnv import FamInst import FamInstEnv -import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import TcDeriv import TcEnv import RnSource ( addTcgDUs ) import TcHsType import TcUnify +import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import Coercion import TyCon import DataCon import Class import Var +import Pair import VarSet import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) @@ -549,8 +551,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) | isTyVarTy ty = return () | otherwise = addErrTc $ mustBeVarArgErr ty checkIndex ty (Just instTy) - | ty `tcEqType` instTy = return () - | otherwise = addErrTc $ wrongATArgErr ty instTy + | ty `eqType` instTy = return () + | otherwise = addErrTc $ wrongATArgErr ty instTy listToNameSet = addListToNameSet emptyNameSet @@ -563,7 +565,183 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) tv1 `sameLexeme` tv2 = nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2) in - extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement + TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement +\end{code} + + +%************************************************************************ +%* * + Type checking family instances +%* * +%************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). + +\begin{code} +tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing +tcFamInstDecl top_lvl (L loc decl) + = -- Prime error recovery, set source location + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; type_families <- xoptM Opt_TypeFamilies + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl (tcdLName decl) + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Perform kind and type checking + ; tc <- tcFamInstDecl1 decl + ; checkValidTyCon tc -- Remember to check validity; + -- no recursion to worry about here + + -- Check that toplevel type instances are not for associated types. + ; when (isTopLevel top_lvl && isAssocFamily tc) + (addErr $ assocInClassErr (tcdName decl)) + + ; return (ATyCon tc) } + +isAssocFamily :: TyCon -> Bool -- Is an assocaited type +isAssocFamily tycon + = case tyConFamInst_maybe tycon of + Nothing -> panic "isAssocFamily: no family?!?" + Just (fam, _) -> isTyConAssoc fam + +assocInClassErr :: Name -> SDoc +assocInClassErr name + = ptext (sLit "Associated type") <+> quotes (ppr name) <+> + ptext (sLit "must be inside a class instance") + + + +tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon + + -- "type instance" +tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for a synonym + checkTc (isFamilyTyCon family) (notFamily family) + ; checkTc (isSynTyCon family) (wrongKindOfFamily family) + + ; -- (1) kind check the right-hand side of the type equation + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better + + -- we need the exact same number of type parameters as the family + -- declaration + ; let famArity = tyConArity family + ; checkTc (length k_typats == famArity) $ + wrongNumberOfParmsErr famArity + + -- (2) type check type equation + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + ; t_typats <- mapM tcHsKindedType k_typats + ; t_rhs <- tcHsKindedType k_rhs + + -- (3) check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc + ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (typeKind t_rhs) + NoParentTyCon (Just (family, t_typats)) + }} + + -- "newtype instance" and "data instance" +tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, + tcdCons = cons}) + = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> + do { -- check that the family declaration is for the right kind + checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) + ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) + + ; -- (1) kind check the data declaration as usual + ; k_decl <- kcDataDecl decl k_tvs + ; let k_ctxt = tcdCtxt k_decl + k_cons = tcdCons k_decl + + -- result kind must be '*' (otherwise, we have too few patterns) + ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) + + -- (2) type check indexed data type declaration + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + ; unbox_strict <- doptM Opt_UnboxStrictFields + + -- kind check the type indexes and the context + ; t_typats <- mapM tcHsKindedType k_typats + ; stupid_theta <- tcHsKindedContext k_ctxt + + -- (3) Check that + -- (a) left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mapM_ checkTyFamFreeness t_typats + + ; dataDeclChecks tc_name new_or_data stupid_theta k_cons + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc + ; let ex_ok = True -- Existentials ok for type families! + ; fixM (\ rep_tycon -> do + { let orig_res_ty = mkTyConApp fam_tycon t_typats + ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon + (t_tvs, orig_res_ty) k_cons + ; tc_rhs <- + case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + }) + }} + where + h98_syntax = case cons of -- All constructors have same shape + L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False + _ -> True + +tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) + +-- Kind checking of indexed types +-- - + +-- Kind check type patterns and kind annotate the embedded type variables. +-- +-- * Here we check that a type instance matches its kind signature, but we do +-- not check whether there is a pattern for each type index; the latter +-- check is only required for type synonym instances. + +kcIdxTyPats :: TyClDecl Name + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) + -- ^^kinded tvs ^^kinded ty pats ^^res kind + -> TcM a +kcIdxTyPats decl thing_inside + = kcHsTyVars (tcdTyVars decl) $ \tvs -> + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name + ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) + ; hs_typats = fromJust $ tcdTyPats decl } + + -- we may not have more parameters than the kind indicates + ; checkTc (length kinds >= length hs_typats) $ + tooManyParmsErr (tcdLName decl) + + -- type functions can have a higher-kinded result + ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] + ; thing_inside tvs typats resultKind fam_tycon + } \end{code} @@ -718,8 +896,8 @@ tcSuperClass n_ty_args ev_vars pred ; return (sc_dict, DFunConstArg (Var sc_dict)) } where find _ [] = Nothing - find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i) - | otherwise = find (i+1) evs + find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i) + | otherwise = find (i+1) evs ------------------------------ tcSpecInstPrags :: DFunId -> InstBindings Name @@ -1042,13 +1220,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys inst_tvs = fst (tcSplitForAllTys (idType dfun_id)) Just (init_inst_tys, _) = snocView inst_tys - rep_ty = fst (coercionKind co) -- [p] + rep_ty = pFst (coercionKind co) -- [p] rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty]) -- co : [p] ~ T p - co = substTyWith inst_tvs (mkTyVarTys tyvars) $ - case coi of { IdCo ty -> ty ; - ACo co -> mkSymCoercion co } + co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $ + mkSymCo coi ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) @@ -1072,7 +1249,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------- mk_op_wrapper :: Id -> EvVar -> HsWrapper mk_op_wrapper sel_id rep_d - = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty) + = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co]) + local_meth_ty) <.> WpEvApp (EvId rep_d) <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) where @@ -1262,4 +1440,37 @@ wrongATArgErr ty instTy = , ptext (sLit "Found") <+> quotes (ppr ty) <+> ptext (sLit "but expected") <+> quotes (ppr instTy) ] + +tooManyParmsErr :: Located Name -> SDoc +tooManyParmsErr tc_name + = ptext (sLit "Family instance has too many parameters:") <+> + quotes (ppr tc_name) + +tooFewParmsErr :: Arity -> SDoc +tooFewParmsErr arity + = ptext (sLit "Family instance has too few parameters; expected") <+> + ppr arity + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity + +badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr + = ptext (sLit "Illegal family instance in hs-boot file") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = ptext (sLit "Wrong category of family instance; declaration was for a") + <+> kindOfFamily + where + kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") + | isAlgTyCon family = ptext (sLit "data type") + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) \end{code} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 4a049aa3ee..f789e6f655 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -408,16 +408,12 @@ dischargeFromCCans cans ev fl discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool discharge_ct ct _rest - | evVarPred (cc_id ct) `tcEqPred` the_pred + | evVarPred (cc_id ct) `eqPred` the_pred , cc_flavor ct `canSolve` fl - = do { when (isWanted fl) $ set_ev_bind ev (cc_id ct) + = do { when (isWanted fl) $ setEvBind ev (evVarTerm (cc_id ct)) -- Deriveds need no evidence -- For Givens, we already have evidence, and we don't need it twice ; return True } - where - set_ev_bind x y - | EqPred {} <- evVarPred y = setEvBind x (EvCoercion (mkCoVarCoercion y)) - | otherwise = setEvBind x (EvId y) discharge_ct _ct rest = rest \end{code} @@ -725,9 +721,10 @@ solveWithIdentity cv wd tv xi ] ; setWantedTyBind tv xi - ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi xi + ; let refl_xi = mkReflCo xi + ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi refl_xi - ; when (isWanted wd) (setCoBind cv xi) + ; when (isWanted wd) (setCoBind cv refl_xi) -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' ; return $ SPSolved (CTyEqCan { cc_id = cv_given @@ -928,7 +925,7 @@ doInteractWithInert :: CanonicalCt -> CanonicalCt -> TcS InteractResult doInteractWithInert inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) - | cls1 == cls2 && (and $ zipWith tcEqType tys1 tys2) + | cls1 == cls2 && eqTypes tys1 tys2 = solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2)) @@ -946,7 +943,7 @@ doInteractWithInert ; case m of Nothing -> noInteraction workItem Just (rewritten_tys2, cos2, fd_work) - | tcEqTypes tys1 rewritten_tys2 + | eqTypes tys1 rewritten_tys2 -> -- Solve him on the spot in this case case fl2 of Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem) @@ -991,7 +988,7 @@ doInteractWithInert workListFromNonEq workItem' `unionWorkList` fd_work } where - dict_co = mkTyConCoercion (classTyCon cls1) cos2 + dict_co = mkTyConAppCo (classTyCon cls1) cos2 } -- Class constraint and given equality: use the equality to rewrite @@ -1043,7 +1040,7 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i -- we must *override* the outer one with the inner one mkIRContinue "IP/IP override" workItem DropInert emptyWorkList - | nm1 == nm2 && ty1 `tcEqType` ty2 + | nm1 == nm2 && ty1 `eqType` ty2 = solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem | nm1 == nm2 @@ -1090,23 +1087,23 @@ doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1 workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2 , cc_tyargs = args2, cc_rhs = xi2 }) | fl1 `canSolve` fl2 && lhss_match - = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) + = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) ; mkIRStopK "FunEq/FunEq" cans } | fl2 `canSolve` fl1 && lhss_match - = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) + = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) ; mkIRContinue "FunEq/FunEq" workItem DropInert cans } where - lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2) + lhss_match = tc1 == tc2 && eqTypes args1 args2 doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 }) -- Check for matching LHS | fl1 `canSolve` fl2 && tv1 == tv2 - = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) + = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) ; mkIRStopK "Eq/Eq lhs" cans } | fl2 `canSolve` fl1 && tv1 == tv2 - = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) + = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) ; mkIRContinue "Eq/Eq lhs" workItem DropInert cans } -- Check for rewriting RHS @@ -1137,13 +1134,13 @@ doInteractWithInert _ workItem = noInteraction workItem -- Equational Rewriting rewriteDict :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt rewriteDict (cv,tv,xi) (dv,gw,cl,xis) - = do { let cos = substTysWith [tv] [mkCoVarCoercion cv] xis -- xis[tv] ~ xis[xi] + = do { let cos = map (liftCoSubstWith [tv] [mkCoVarCo cv]) xis -- xis[tv] ~ xis[xi] args = substTysWith [tv] [xi] xis con = classTyCon cl - dict_co = mkTyConCoercion con cos + dict_co = mkTyConAppCo con cos ; dv' <- newDictVar cl args ; case gw of - Wanted {} -> setDictBind dv (EvCast dv' (mkSymCoercion dict_co)) + Wanted {} -> setDictBind dv (EvCast dv' (mkSymCo dict_co)) Given {} -> setDictBind dv' (EvCast dv dict_co) Derived {} -> return () -- Derived dicts we don't set any evidence @@ -1154,11 +1151,11 @@ rewriteDict (cv,tv,xi) (dv,gw,cl,xis) rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) - = do { let ip_co = substTyWith [tv] [mkCoVarCoercion cv] ty -- ty[tv] ~ t[xi] - ty' = substTyWith [tv] [xi] ty + = do { let ip_co = liftCoSubstWith [tv] [mkCoVarCo cv] ty -- ty[tv] ~ t[xi] + ty' = substTyWith [tv] [xi] ty ; ipid' <- newIPVar nm ty' ; case gw of - Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCoercion ip_co)) + Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCo ip_co)) Given {} -> setIPBind ipid' (EvCast ipid ip_co) Derived {} -> return () -- Derived ips: we don't set any evidence @@ -1169,20 +1166,21 @@ rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2) -- cv2 :: F args ~ xi2 - = do { let arg_cos = substTysWith [tv] [mkCoVarCoercion cv1] args - args' = substTysWith [tv] [xi1] args - fun_co = mkTyConCoercion tc arg_cos -- fun_co :: F args ~ F args' + = do { let co_subst = liftCoSubstWith [tv] [mkCoVarCo cv1] + arg_cos = map co_subst args + args' = substTysWith [tv] [xi1] args + fun_co = mkTyConAppCo tc arg_cos -- fun_co :: F args ~ F args' xi2' = substTyWith [tv] [xi1] xi2 - xi2_co = substTyWith [tv] [mkCoVarCoercion cv1] xi2 -- xi2_co :: xi2 ~ xi2' + xi2_co = co_subst xi2 -- xi2_co :: xi2 ~ xi2' ; cv2' <- newCoVar (mkTyConApp tc args') xi2' ; case gw of - Wanted {} -> setCoBind cv2 (fun_co `mkTransCoercion` - mkCoVarCoercion cv2' `mkTransCoercion` - mkSymCoercion xi2_co) - Given {} -> setCoBind cv2' (mkSymCoercion fun_co `mkTransCoercion` - mkCoVarCoercion cv2 `mkTransCoercion` + Wanted {} -> setCoBind cv2 (fun_co `mkTransCo` + mkCoVarCo cv2' `mkTransCo` + mkSymCo xi2_co) + Given {} -> setCoBind cv2' (mkSymCo fun_co `mkTransCo` + mkCoVarCo cv2 `mkTransCo` xi2_co) Derived {} -> return () @@ -1203,20 +1201,20 @@ rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS WorkLis rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) | Just tv2' <- tcGetTyVar_maybe xi2' , tv2 == tv2' -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2 - = do { when (isWanted gw) (setCoBind cv2 (mkSymCoercion co2')) + = do { when (isWanted gw) (setCoBind cv2 (mkSymCo co2')) ; return emptyWorkList } | otherwise = do { cv2' <- newCoVar (mkTyVarTy tv2) xi2' ; case gw of - Wanted {} -> setCoBind cv2 $ mkCoVarCoercion cv2' `mkTransCoercion` - mkSymCoercion co2' - Given {} -> setCoBind cv2' $ mkCoVarCoercion cv2 `mkTransCoercion` + Wanted {} -> setCoBind cv2 $ mkCoVarCo cv2' `mkTransCo` + mkSymCo co2' + Given {} -> setCoBind cv2' $ mkCoVarCo cv2 `mkTransCo` co2' Derived {} -> return () ; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' } where xi2' = substTyWith [tv1] [xi1] xi2 - co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1] + co2' = liftCoSubstWith [tv1] [mkCoVarCo cv1] xi2 -- xi2 ~ xi2[xi1/tv1] rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList -- Used to ineract two equalities of the following form: @@ -1229,9 +1227,9 @@ rewriteEqLHS LeftComesFromInert (co1,xi1) (cv2,gw,xi2) = do { cv2' <- newCoVar xi2 xi1 ; case gw of Wanted {} -> setCoBind cv2 $ - co1 `mkTransCoercion` mkSymCoercion (mkCoVarCoercion cv2') + co1 `mkTransCo` mkSymCo (mkCoVarCo cv2') Given {} -> setCoBind cv2' $ - mkSymCoercion (mkCoVarCoercion cv2) `mkTransCoercion` co1 + mkSymCo (mkCoVarCo cv2) `mkTransCo` co1 Derived {} -> return () ; mkCanonical gw cv2' } @@ -1239,9 +1237,9 @@ rewriteEqLHS RightComesFromInert (co1,xi1) (cv2,gw,xi2) = do { cv2' <- newCoVar xi1 xi2 ; case gw of Wanted {} -> setCoBind cv2 $ - co1 `mkTransCoercion` mkCoVarCoercion cv2' + co1 `mkTransCo` mkCoVarCo cv2' Given {} -> setCoBind cv2' $ - mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2 + mkSymCo co1 `mkTransCo` mkCoVarCo cv2 Derived {} -> return () ; mkCanonical gw cv2' } @@ -1249,12 +1247,12 @@ rewriteFrozen :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor) -> TcS WorkList rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) = do { cv2' <- newCoVar ty2a' ty2b' -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1] ; case fl2 of - Wanted {} -> setCoBind cv2 $ co2a' `mkTransCoercion` - mkCoVarCoercion cv2' `mkTransCoercion` - mkSymCoercion co2b' + Wanted {} -> setCoBind cv2 $ co2a' `mkTransCo` + mkCoVarCo cv2' `mkTransCo` + mkSymCo co2b' - Given {} -> setCoBind cv2' $ mkSymCoercion co2a' `mkTransCoercion` - mkCoVarCoercion cv2 `mkTransCoercion` + Given {} -> setCoBind cv2' $ mkSymCo co2a' `mkTransCo` + mkCoVarCo cv2 `mkTransCo` co2b' Derived {} -> return () @@ -1265,8 +1263,8 @@ rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) ty2a' = substTyWith [tv1] [xi1] ty2a ty2b' = substTyWith [tv1] [xi1] ty2b - co2a' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2a -- ty2a ~ ty2a[xi1/tv1] - co2b' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2b -- ty2b ~ ty2b[xi1/tv1] + co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a -- ty2a ~ ty2a[xi1/tv1] + co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b -- ty2b ~ ty2b[xi1/tv1] solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult -- First argument inert, second argument work-item. They both represent @@ -1734,7 +1732,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc) ; case m of Nothing -> return NoTopInt Just (xis',cos,fd_work) -> - do { let dict_co = mkTyConCoercion (classTyCon cls) cos + do { let dict_co = mkTyConAppCo (classTyCon cls) cos ; dv'<- newDictVar cls xis' ; setDictBind dv (EvCast dv' dict_co) ; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl, @@ -1783,15 +1781,15 @@ doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl -- RHS of a type function, so that it never -- appears in an error message -- See Note [Type synonym families] in TyCon - coe = mkTyConApp coe_tc rep_tys + coe = mkAxInstCo coe_tc rep_tys ; cv' <- case fl of Wanted {} -> do { cv' <- newCoVar rhs_ty xi ; setCoBind cv $ - coe `mkTransCoercion` - mkCoVarCoercion cv' + coe `mkTransCo` + mkCoVarCo cv' ; return cv' } Given {} -> newGivenCoVar xi rhs_ty $ - mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe + mkSymCo (mkCoVarCo cv) `mkTransCo` coe Derived {} -> newDerivedId (EqPred xi rhs_ty) ; can_cts <- mkCanonical fl cv' ; return $ SomeTopInt can_cts Stop } diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 74533340f3..88493bf1ab 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -26,7 +26,6 @@ module TcMType ( -------------------------------- -- Creating new evidence variables newEvVar, newCoVar, newEvVars, - writeWantedCoVar, readWantedCoVar, newIP, newDict, newSilentGiven, isSilentEvVar, newWantedEvVar, newWantedEvVars, @@ -43,16 +42,15 @@ module TcMType ( -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, - checkValidInstance, - checkValidTypeInst, checkTyFamFreeness, + checkValidInstHead, checkValidInstance, + checkInstTermination, checkValidTypeInst, checkTyFamFreeness, arityErr, growPredTyVars, growThetaTyVars, validDerivPred, -------------------------------- -- Zonking zonkType, mkZonkTcTyVar, zonkTcPredType, - zonkTcTypeCarefully, - skolemiseUnboundMetaTyVar, + zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, @@ -72,7 +70,6 @@ module TcMType ( import TypeRep import TcType import Type -import Coercion import Class import TyCon import Var @@ -145,7 +142,7 @@ newEvVar (IParam ip ty) = newIP ip ty newCoVar :: TcType -> TcType -> TcM CoVar newCoVar ty1 ty2 - = do { name <- newName (mkTyVarOccFS (fsLit "co")) + = do { name <- newName (mkVarOccFS (fsLit "co")) ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) } newIP :: IPName Name -> TcType -> TcM IpId @@ -301,10 +298,6 @@ readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) -readWantedCoVar :: CoVar -> TcM MetaDetails -readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar ) - readMutVar (metaTvRef covar) - isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv @@ -343,9 +336,6 @@ writeMetaTyVar tyvar ty = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) return () -writeWantedCoVar :: CoVar -> Coercion -> TcM () -writeWantedCoVar cv co = writeMetaTyVar cv co - -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; @@ -745,13 +735,12 @@ zonkType zonk_tc_tyvar ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = liftM TyVarTy $ - zonkTyVar zonk_tc_tyvar tyvar + | otherwise = return (TyVarTy tyvar) -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- zonkTyVar zonk_tc_tyvar tyvar + tyvar' <- return tyvar return (ForAllTy tyvar' ty') go_pred (ClassP c tys) = do tys' <- mapM go tys @@ -774,16 +763,6 @@ mkZonkTcTyVar unbound_var_fn tyvar ; case cts of Flexi -> unbound_var_fn tyvar Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty } - --- Zonk the kind of a non-TC tyvar in case it is a coercion variable --- (their kind contains types). -zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for a TcTyVar - -> TyVar -> TcM TyVar -zonkTyVar zonk_tc_tyvar tv - | isCoVar tv - = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv) - ; return $ setTyVarKind tv kind } - | otherwise = return tv \end{code} @@ -1154,7 +1133,7 @@ check_valid_theta ctxt theta = do warnTc (notNull dups) (dupPredWarn dups) mapM_ (check_pred_ty dflags ctxt) theta where - (_,dups) = removeDups tcCmpPred theta + (_,dups) = removeDups cmpPred theta ------------------------- check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () @@ -1276,7 +1255,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars ambigErr :: PredType -> SDoc ambigErr pred - = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred), + = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred), nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} @@ -1343,14 +1322,14 @@ eqSuperClassErr pred 2 (ppr pred) badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc -badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred -eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred +badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred +eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred $$ parens (ptext (sLit "Use -XTypeFamilies to permit this")) predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] dupPredWarn :: [[PredType]] -> SDoc -dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups) arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m @@ -1498,7 +1477,7 @@ checkInstTermination tys theta predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] nomoreMsg, smallerMsg, undecidableMsg :: SDoc nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head") diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 860a6dbd92..f912039be7 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -28,7 +28,7 @@ import TysWiredIn import Id import TyCon import TysPrim -import Coercion ( mkSymCoI ) +import Coercion ( mkSymCo ) import Outputable import BasicTypes ( Arity ) import Util @@ -143,7 +143,7 @@ matchFunTys matchFunTys herald arity res_ty thing_inside = do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty ; res <- thing_inside pat_tys res_ty - ; return (coiToHsWrapper (mkSymCoI coi), res) } + ; return (coToHsWrapper (mkSymCo coi), res) } \end{code} %************************************************************************ @@ -246,7 +246,7 @@ tcDoStmts ListComp stmts body res_ty ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $ tcBody body - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (HsDo ListComp stmts' body' (mkListTy elt_ty)) } tcDoStmts PArrComp stmts body res_ty @@ -254,7 +254,7 @@ tcDoStmts PArrComp stmts body res_ty ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $ tcBody body - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } tcDoStmts DoExpr stmts body res_ty diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index d28e901325..250122529b 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -149,7 +149,7 @@ data TcSigInfo instance Outputable TcSigInfo where ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) - = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau + = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau \end{code} Note [sig_tau may be polymorphic] @@ -193,7 +193,7 @@ res_ty free vars. %************************************************************************ \begin{code} -tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId) +tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- @@ -205,11 +205,11 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty | otherwise = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty - ; return (IdCo pat_ty, bndr_id) } + ; return (mkReflCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty = do { bndr <- mkLocalBinder bndr_name pat_ty - ; return (IdCo pat_ty, bndr) } + ; return (mkReflCo pat_ty, bndr) } ------------ newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId @@ -373,7 +373,7 @@ tc_pat :: PatEnv tc_pat penv (VarPat name) pat_ty thing_inside = do { (coi, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside - ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) } + ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) } tc_pat penv (ParPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -423,7 +423,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- perhaps be fixed, but only with a bit more work. -- -- If you fix it, don't forget the bindInstsOfPatIds! - ; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside = do { checkUnboxedTuple overall_pat_ty $ @@ -448,7 +448,7 @@ tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside -- pattern must have pat_ty ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) } + ; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) } -- Type signatures in patterns -- See Note [Pattern coercions] below @@ -511,7 +511,7 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside ; coi <- unifyPatType lit_ty pat_ty -- coi is of kind: pat_ty ~ lit_ty ; res <- thing_inside - ; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty + ; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty , res) } ------------------------ @@ -546,19 +546,19 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside ; instStupidTheta orig [mkClassPred icls [pat_ty']] ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; return (mkHsWrapPatCoI coi pat' pat_ty, res) } + ; return (mkHsWrapPatCo coi pat' pat_ty, res) } tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut ---------------- -unifyPatType :: TcType -> TcType -> TcM CoercionI +unifyPatType :: TcType -> TcType -> TcM Coercion -- In patterns we want a coercion from the -- context type (expected) to the actual pattern type -- But we don't want to reverse the args to unifyType because -- that controls the actual/expected stuff in error messages unifyPatType actual_ty expected_ty = do { coi <- unifyType actual_ty expected_ty - ; return (mkSymCoI coi) } + ; return (mkSymCo coi) } \end{code} Note [Hopping the LIE in lazy patterns] @@ -657,7 +657,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside = do { data_con <- tcLookupDataCon con_name ; let tycon = dataConTyCon data_con -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con -- Instantiate the constructor type variables [a->ty] @@ -679,9 +679,8 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) (ctxt_res_tys ++ mkTyVarTys ex_tvs') arg_tys' = substTys tenv arg_tys - full_theta = eq_theta ++ dict_theta - ; if null ex_tvs && null eq_spec && null full_theta + ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) (arg_pats', res) <- tcConArgs data_con arg_tys' @@ -697,7 +696,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside else do -- The general case, with existential, -- and local equality constraints { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec] - theta' = substTheta tenv (eq_preds ++ full_theta) + theta' = substTheta tenv (eq_preds ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta' no_equalities = not (any isEqPred theta') @@ -726,21 +725,21 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside } } ---------------------------- -matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a)) +matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a)) -> TcRhoType -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~ inner_ty matchExpectedPatTy inner_match pat_ty | null tvs && null theta = do { (coi, res) <- inner_match pat_ty - ; return (coiToHsWrapper (mkSymCoI coi), res) } + ; return (coToHsWrapper (mkSymCo coi), res) } -- The Sym is because the inner_match returns a coercion -- that is the other way round to matchExpectedPatTy | otherwise = do { (_, tys, subst) <- tcInstTyVars tvs ; wrap1 <- instCall PatOrigin tys (substTheta subst theta) - ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau) + ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau) ; return (wrap2 <.> wrap1 , arg_tys) } where (tvs, theta, tau) = tcSplitSigmaTy pat_ty @@ -749,7 +748,7 @@ matchExpectedPatTy inner_match pat_ty matchExpectedConTy :: TyCon -- The TyCon that this data -- constructor actually returns -> TcRhoType -- The type of the pattern - -> TcM (CoercionI, [TcSigmaType]) + -> TcM (Coercion, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a coercion : T ty1 ... tyn ~ pat_ty -- This is the same way round as matchExpectedListTy etc @@ -764,10 +763,10 @@ matchExpectedConTy data_tc pat_ty ; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty -- coi1 : T (ty1,ty2) ~ pat_ty - ; let coi2 = ACo (mkTyConApp co_tc tys) + ; let coi2 = mkAxInstCo co_tc tys -- coi2 : T (ty1,ty2) ~ T7 ty1 ty2 - ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) } + ; return (mkTransCo (mkSymCo coi2) coi1, tys) } | otherwise = matchExpectedTyConApp data_tc pat_ty diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 23c2e67daa..e2c79ee393 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -65,7 +65,6 @@ import Name import NameEnv import NameSet import TyCon -import TysPrim import SrcLoc import HscTypes import ListSetOps @@ -73,6 +72,7 @@ import Outputable import DataCon import Type import Class +import Pair import TcType ( orphNamesOfDFunHead ) import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) @@ -645,7 +645,7 @@ checkHiBootIface check_inst boot_inst = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, - idType dfun `tcEqType` boot_inst_ty ] of + idType dfun `eqType` boot_inst_ty ] of [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) , text "boot_inst" <+> ppr boot_inst , text "boot_inst_ty" <+> ppr boot_inst_ty @@ -669,7 +669,7 @@ checkBootDecl :: TyThing -> TyThing -> Bool checkBootDecl (AnId id1) (AnId id2) = ASSERT(id1 == id2) - (idType id1 `tcEqType` idType id2) + (idType id1 `eqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) = checkBootTyCon tc1 tc2 @@ -686,7 +686,7 @@ checkBootDecl (AClass c1) (AClass c2) eqSig (id1, def_meth1) (id2, def_meth2) = idName id1 == idName id2 && - tcEqTypeX env op_ty1 op_ty2 && + eqTypeX env op_ty1 op_ty2 && def_meth1 == def_meth2 where (_, rho_ty1) = splitForAllTys (idType id1) @@ -695,8 +695,8 @@ checkBootDecl (AClass c1) (AClass c2) op_ty2 = funResultTy rho_ty2 eqFD (as1,bs1) (as2,bs2) = - eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2) in @@ -705,7 +705,7 @@ checkBootDecl (AClass c1) (AClass c2) eqListBy eqFD clas_fds1 clas_fds2 && (null sc_theta1 && null op_stuff1 && null ats1 || -- Above tests for an "abstract" class - eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && + eqListBy (eqPredX env) sc_theta1 sc_theta2 && eqListBy eqSig op_stuff1 op_stuff2 && eqListBy checkBootTyCon ats1 ats2) @@ -728,7 +728,7 @@ checkBootTyCon tc1 tc2 eqSynRhs SynFamilyTyCon SynFamilyTyCon = True eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) - = tcEqTypeX env t1 t2 + = eqTypeX env t1 t2 eqSynRhs _ _ = False in equalLength tvs1 tvs2 && @@ -737,7 +737,7 @@ checkBootTyCon tc1 tc2 | isAlgTyCon tc1 && isAlgTyCon tc2 = ASSERT(tc1 == tc2) eqKind (tyConKind tc1) (tyConKind tc2) && - eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && + eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) | isForeignTyCon tc1 && isForeignTyCon tc2 @@ -761,17 +761,7 @@ checkBootTyCon tc1 tc2 && dataConIsInfix c1 == dataConIsInfix c2 && dataConStrictMarks c1 == dataConStrictMarks c2 && dataConFieldLabels c1 == dataConFieldLabels c2 - && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1 - tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2 - env = rnBndrs2 env0 tvs1 tvs2 - in - equalLength tvs1 tvs2 && - eqListBy (tcEqPredX env) - (dataConEqTheta c1 ++ dataConDictTheta c1) - (dataConEqTheta c2 ++ dataConDictTheta c2) && - eqListBy (tcEqTypeX env) - (dataConOrigArgTys c1) - (dataConOrigArgTys c2) + && eqType (dataConUserType c1) (dataConUserType c2) ---------------- missingBootThing :: Name -> String -> SDoc @@ -1325,16 +1315,13 @@ tcRnExpr hsc_env ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - uniq <- newUnique ; let { fresh_it = itName uniq } ; - ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _), lie_top) <- captureConstraints $ - simplifyInfer TopLevel - False {- No MR for now -} + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _), lie_top) <- captureConstraints $ + simplifyInfer TopLevel False {- No MR for now -} [(fresh_it, res_ty)] lie ; - _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; @@ -1621,7 +1608,10 @@ ppr_types insts type_env ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env - = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons) + = vcat [ text "TYPE CONSTRUCTORS" + , nest 2 (ppr_tydecls tycons) + , text "COERCION AXIOMS" + , nest 2 (ppr_axioms (typeEnvCoAxioms type_env)) ] where fi_tycons = map famInstTyCon fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] @@ -1653,13 +1643,16 @@ ppr_tydecls tycons = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 - ppr_tycon tycon - | isCoercionTyCon tycon - = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs - , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))] - | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) + ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon)) where - tvs = take (tyConArity tycon) alphaTyVars + +ppr_axioms :: [CoAxiom] -> SDoc +ppr_axioms axs + = vcat (map ppr_ax axs) + where + ppr_ax ax = sep [ ptext (sLit "coercion") <+> ppr ax <+> ppr (co_ax_tvs ax) + , nest 2 (dcolon <+> pprEqPred + (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ] ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ad2405b95e..9193eb5ea0 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -406,7 +406,6 @@ traceRn, traceSplice :: SDoc -> TcRn () traceRn = traceOptTcRn Opt_D_dump_rn_trace traceSplice = traceOptTcRn Opt_D_dump_splices - traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs @@ -897,6 +896,9 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts + | opt_PprStyle_Debug -- In -dppr-debug style the output + = return empty -- just becomes too voluminous + | otherwise = go 0 env ctxts where go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 3367f06ded..30dccc2437 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -42,7 +42,7 @@ module TcRnTypes( CtOrigin(..), EqOrigin(..), WantedLoc, GivenLoc, pushErrCtxt, - SkolemInfo(..), + SkolemInfo(..), CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived, FlavoredEvVar, @@ -62,6 +62,7 @@ module TcRnTypes( import HsSyn import HscTypes import Type +import Id ( evVarPred ) import Class ( Class ) import DataCon ( DataCon, dataConUserType ) import TcType @@ -324,6 +325,7 @@ data IfLclEnv -- plus which bit is currently being examined if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings + -- (and coercions) if_id_env :: UniqFM Id -- Nested id binding } \end{code} @@ -674,7 +676,6 @@ instance Outputable WhereFrom where %************************************************************************ %* * Wanted constraints - These are forced to be in TcRnTypes because TcLclEnv mentions WantedConstraints WantedConstraint mentions CtLoc @@ -901,7 +902,7 @@ pprEvVarTheta :: [EvVar] -> SDoc pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v) +pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v) pprWantedsWithLocs :: WantedConstraints -> SDoc pprWantedsWithLocs wcs diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index b2c1dac620..3925c6def3 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -17,7 +17,6 @@ import TcHsType import TcExpr import TcEnv import Id -import Var ( Var ) import Name import VarSet import SrcLoc diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 87cd5eb2b1..13c7377e00 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -82,6 +82,7 @@ import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys ) +import Kind import TcType import DynFlags @@ -97,6 +98,7 @@ import Outputable import Bag import MonadUtils import VarSet +import Pair import FastString import HsBinds -- for TcEvBinds stuff @@ -204,9 +206,9 @@ instance Outputable CanonicalCt where ppr (CIPCan ip fl ip_nm ty) = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty) ppr (CTyEqCan co fl tv ty) - = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty) + = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty) ppr (CFunEqCan co fl tc tys ty) - = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty) + = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty) ppr (CFrozenErr co fl) = ppr fl <+> pprEvVarWithType co \end{code} @@ -525,8 +527,8 @@ runTcS context untouch tcs ; mapM_ do_unification (varEnvElts ty_binds) #ifdef DEBUG - ; count <- TcM.readTcRef step_count - ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) +-- ; count <- TcM.readTcRef step_count +-- ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) #endif -- And return ; ev_binds <- TcM.readTcRef evb_ref @@ -672,7 +674,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index eecfb279c0..0012b1ea5b 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1,7 +1,7 @@ \begin{code} module TcSimplify( simplifyInfer, - simplifyDefault, simplifyDeriv, + simplifyDefault, simplifyDeriv, simplifyRule, simplifyTop, simplifyInteractive ) where @@ -15,10 +15,12 @@ import TcType import TcSMonad import TcInteract import Inst -import Unify( niFixTvSubst, niSubstTvSet ) +import Id ( evVarPred ) +import Unify ( niFixTvSubst, niSubstTvSet ) import Var import VarSet import VarEnv +import Coercion import TypeRep import Name @@ -982,7 +984,8 @@ solveCTyFunEqs cts ; return (niFixTvSubst ni_subst, unsolved_can_cts) } where - solve_one (cv,tv,ty) = setWantedTyBind tv ty >> setCoBind cv ty + solve_one (cv,tv,ty) = do { setWantedTyBind tv ty + ; setCoBind cv (mkReflCo ty) } ------------ type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)]) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index f68239ee26..d6517a6772 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -71,6 +71,7 @@ import SrcLoc import Outputable import Util ( dropList ) import Data.List ( mapAccumL ) +import Pair import Unique import Data.Maybe import BasicTypes @@ -1066,8 +1067,9 @@ reifyThing (AGlobal (AnId id)) _ -> return (TH.VarI v ty Nothing fix) } -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AClass cls)) = reifyClass cls +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax +reifyThing (AGlobal (AClass cls)) = reifyClass cls reifyThing (AGlobal (ADataCon dc)) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) @@ -1091,12 +1093,24 @@ reifyThing (ATyVar tv ty) reifyThing (AThing {}) = panic "reifyThing AThing" ------------------------------ +reifyAxiom :: CoAxiom -> TcM TH.Info +reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs }) + | Just (tc, args) <- tcSplitTyConApp_maybe lhs + = do { args' <- mapM reifyType args + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') } + | otherwise + = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax + <+> dcolon <+> pprEqPred (Pair lhs rhs)) + reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) + | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) + | isFamilyTyCon tc = let flavour = reifyFamFlavour tc tvs = tyConTyVars tc @@ -1107,6 +1121,7 @@ reifyTyCon tc in return (TH.TyConI $ TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind') + | isSynTyCon tc = do { let (tvs, rhs) = synTyConDefn tc ; rhs' <- reifyType rhs @@ -1114,7 +1129,7 @@ reifyTyCon tc TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } -reifyTyCon tc + | otherwise = do { cxt <- reifyCxt (tyConStupidTheta tc) ; let tvs = tyConTyVars tc ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a433d697b9..56bf75838f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,7 +7,8 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds + tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds, + checkValidTyCon, dataDeclChecks, badFamInstDecl ) where #include "HsVersions.h" @@ -137,188 +138,6 @@ zipRecTyClss decls_s rec_things %************************************************************************ %* * - Type checking family instances -%* * -%************************************************************************ - -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). - -\begin{code} -tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing -tcFamInstDecl top_lvl (L loc decl) - = -- Prime error recovery, set source location - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; type_families <- xoptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Perform kind and type checking - ; tc <- tcFamInstDecl1 decl - ; checkValidTyCon tc -- Remember to check validity; - -- no recursion to worry about here - - -- Check that toplevel type instances are not for associated types. - ; when (isTopLevel top_lvl && isAssocFamily tc) - (addErr $ assocInClassErr (tcdName decl)) - - ; return (ATyCon tc) } - -isAssocFamily :: TyCon -> Bool -- Is an assocaited type -isAssocFamily tycon - = case tyConFamInst_maybe tycon of - Nothing -> panic "isAssocFamily: no family?!?" - Just (fam, _) -> isTyConAssoc fam - -assocInClassErr :: Name -> SDoc -assocInClassErr name - = ptext (sLit "Associated type") <+> quotes (ppr name) <+> - ptext (sLit "must be inside a class instance") - - - -tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon - - -- "type instance" -tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> - do { -- check that the family declaration is for a synonym - checkTc (isFamilyTyCon family) (notFamily family) - ; checkTc (isSynTyCon family) (wrongKindOfFamily family) - - ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better - - -- we need the exact same number of type parameters as the family - -- declaration - ; let famArity = tyConArity family - ; checkTc (length k_typats == famArity) $ - wrongNumberOfParmsErr famArity - - -- (2) type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; t_typats <- mapM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType k_rhs - - -- (3) check the well-formedness of the instance - ; checkValidTypeInst t_typats t_rhs - - -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) - (typeKind t_rhs) - NoParentTyCon (Just (family, t_typats)) - }} - - -- "newtype instance" and "data instance" -tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> - do { -- check that the family declaration is for the right kind - checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) - ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) - - ; -- (1) kind check the data declaration as usual - ; k_decl <- kcDataDecl decl k_tvs - ; let k_ctxt = tcdCtxt k_decl - k_cons = tcdCons k_decl - - -- result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) - - -- (2) type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; unbox_strict <- doptM Opt_UnboxStrictFields - - -- kind check the type indexes and the context - ; t_typats <- mapM tcHsKindedType k_typats - ; stupid_theta <- tcHsKindedContext k_ctxt - - -- (3) Check that - -- (a) left-hand side contains no type family applications - -- (vanilla synonyms are fine, though, and we checked for - -- foralls earlier) - ; mapM_ checkTyFamFreeness t_typats - - -- Check that we don't use GADT syntax in H98 world - ; gadt_ok <- xoptM Opt_GADTs - ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name) - - -- (b) a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton k_cons) $ - newtypeConError tc_name (length k_cons) - - -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; let ex_ok = True -- Existentials ok for type families! - ; fixM (\ rep_tycon -> do - { let orig_res_ty = mkTyConApp fam_tycon t_typats - ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon - (t_tvs, orig_res_ty) k_cons - ; tc_rhs <- - case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) - ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - }) - }} - where - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - _ -> True - -tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) - --- Kind checking of indexed types --- - - --- Kind check type patterns and kind annotate the embedded type variables. --- --- * Here we check that a type instance matches its kind signature, but we do --- not check whether there is a pattern for each type index; the latter --- check is only required for type synonym instances. - -kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) - -- ^^kinded tvs ^^kinded ty pats ^^res kind - -> TcM a -kcIdxTyPats decl thing_inside - = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { let tc_name = tcdLName decl - ; fam_tycon <- tcLookupLocatedTyCon tc_name - ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) - ; hs_typats = fromJust $ tcdTyPats decl } - - -- we may not have more parameters than the kind indicates - ; checkTc (length kinds >= length hs_typats) $ - tooManyParmsErr (tcdLName decl) - - -- type functions can have a higher-kinded result - ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckLHsType hs_typats - [ EK kind (EkArg (ppr tc_name) n) - | (kind,n) <- kinds `zip` [1..]] - ; thing_inside tvs typats resultKind fam_tycon - } -\end{code} - - -%************************************************************************ -%* * Kind checking %* * %************************************************************************ @@ -662,34 +481,17 @@ tcTyClDecl1 _parent calc_isrec ; stupid_theta <- tcHsKindedContext ctxt ; want_generic <- xoptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields - ; empty_data_decls <- xoptM Opt_EmptyDataDecls ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs - ; gadtSyntax_ok <- xoptM Opt_GADTSyntax ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - -- Check that we don't use GADT syntax in H98 world - ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name) - -- Check that we don't use kind signatures without Glasgow extensions ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + ; dataDeclChecks tc_name new_or_data stupid_theta cons - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; tycon <- fixM (\ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) ; data_cons <- tcConDecls unbox_strict ex_ok @@ -747,6 +549,29 @@ tcTyClDecl1 _ _ tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d) +dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM () +dataDeclChecks tc_name new_or_data stupid_theta cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM Opt_GADTSyntax + ; let h98_syntax = consUseH98Syntax cons + ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration + ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) } + ----------------------------------- tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] @@ -1099,14 +924,14 @@ checkNewDataCon con -- One argument ; checkTc (null eq_spec) (newtypePredError con) -- Return type is (T a b c) - ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) + ; checkTc (null ex_tvs && null theta) (newtypeExError con) -- No existentials ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } where - (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con ------------------------------- checkValidClass :: Class -> TcM () @@ -1511,39 +1336,6 @@ badFamInstDecl tc_name quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] -tooManyParmsErr :: Located Name -> SDoc -tooManyParmsErr tc_name - = ptext (sLit "Family instance has too many parameters:") <+> - quotes (ppr tc_name) - -tooFewParmsErr :: Arity -> SDoc -tooFewParmsErr arity - = ptext (sLit "Family instance has too few parameters; expected") <+> - ppr arity - -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") - <+> ppr exp_arity - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = ptext (sLit "Illegal family instance in hs-boot file") - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = ptext (sLit "Wrong category of family instance; declaration was for a") - <+> kindOfFamily - where - kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") - | isAlgTyCon family = ptext (sLit "data type") - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index a9ea11aefa..cb61726a5c 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -356,8 +356,8 @@ tcTyConsOfType ty go (FunTy a b) = go a `plusNameEnv` go b go (PredTy (IParam _ ty)) = go ty go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys + go (PredTy (EqPred ty1 ty2)) = go ty1 `plusNameEnv` go ty2 go (ForAllTy _ ty) = go ty - go _ = panic "tcTyConsOfType" go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index eab07326b1..f2b090b94c 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -19,7 +19,7 @@ module TcType ( -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcKind, TcCoVar, + TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar, -------------------------------- -- MetaDetails @@ -50,7 +50,7 @@ module TcType ( --------------------------------- -- Predicates. -- Again, newtypes are opaque - tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, + eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, eqKind, isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, @@ -61,18 +61,11 @@ module TcType ( --------------------------------- -- Misc type manipulators deNoteType, - orphNamesOfType, orphNamesOfDFunHead, + orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo, getDFunTyKey, --------------------------------- -- Predicate types - getClassPredTys_maybe, getClassPredTys, - isClassPred, isTyVarClassPred, isEqPred, - mkClassPred, mkIPPred, tcSplitPredTy_maybe, - mkDictTy, evVarPred, - isPredTy, isDictTy, isDictLikeTy, - tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - isIPPred, mkMinimalBySCs, transSuperClasses, immSuperClasses, -- * Tidying type related things up for printing @@ -81,7 +74,8 @@ module TcType ( tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTopType, tidyPred, - tidyKind, + tidyKind, + tidyCo, tidyCos, --------------------------------- -- Foreign import and export @@ -101,32 +95,38 @@ module TcType ( tcSplitIOType_maybe, -- :: Type -> Maybe Type -------------------------------- - -- Rexported from Coercion - typeKind, - - -------------------------------- - -- Rexported from Type - Kind, -- Stuff to do with kinds is insensitive to pre/post Tc + -- Rexported from Kind + Kind, typeKind, unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, - Type, PredType(..), ThetaType, + -------------------------------- + -- Rexported from Type + Type, Pred(..), PredType, ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, + getClassPredTys_maybe, getClassPredTys, + isClassPred, isTyVarClassPred, isEqPred, + mkClassPred, mkIPPred, splitPredTy_maybe, + mkDictTy, isPredTy, isDictTy, isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, + isIPPred, mkEqPred, + -- Type substitutions TvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTvSubst, substEqSpec, + TvSubstEnv, emptyTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, unionTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar, - extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, - substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr, + getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr, + extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, + Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto @@ -138,13 +138,14 @@ module TcType ( pprKind, pprParendKind, pprType, pprParendType, pprTypeApp, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred + pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred ) where #include "HsVersions.h" -- friends: +import Kind import TypeRep import Class import Var @@ -156,7 +157,7 @@ import TyCon -- others: import DynFlags -import Name +import Name hiding (varName) import NameSet import VarEnv import PrelNames @@ -168,6 +169,8 @@ import ListSetOps import Outputable import FastString +import qualified Data.Foldable as Foldable +import Data.Functor( (<$>) ) import Data.List( mapAccumL ) import Data.IORef \end{code} @@ -216,6 +219,8 @@ type TcType = Type -- A TcType can have mutable type variables -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a +type TcCoercion = Coercion -- A TcCoercion can contain TcTypes. + -- These types do not have boxy type variables in them type TcPredType = PredType type TcThetaType = ThetaType @@ -262,7 +267,7 @@ the same type variable in both type signatures. But that takes explanation. The alternative (currently implemented) is to have a special kind of skolem constant, SigTv, which can unify with other SigTvs. These are *not* treated -as righd for the purposes of GADTs. And they are used *only* for pattern +as rigid for the purposes of GADTs. And they are used *only* for pattern bindings and mutually recursive function bindings. See the function TcBinds.tcInstSig, and its use_skols parameter. @@ -392,7 +397,7 @@ kind_var_occ = mkOccName tvName "k" \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") +pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk") pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") @@ -428,19 +433,13 @@ pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") -- -- It doesn't change the uniques at all, just the print names. tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr env@(tidy_env, subst) tyvar +tidyTyVarBndr (tidy_env, subst) tyvar = case tidyOccName tidy_env occ1 of - (tidy', occ') -> ((tidy', subst'), tyvar'') + (tidy', occ') -> ((tidy', subst'), tyvar') where - subst' = extendVarEnv subst tyvar tyvar'' + subst' = extendVarEnv subst tyvar tyvar' tyvar' = setTyVarName tyvar name' - - name' = tidyNameOcc name occ' - - -- Don't forget to tidy the kind for coercions! - tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind' - | otherwise = tyvar' - kind' = tidyType env (tyVarKind tyvar) + name' = tidyNameOcc name occ' where name = tyVarName tyvar occ = getOccName name @@ -529,6 +528,41 @@ tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) tidyKind env k = tidyOpenType env k \end{code} +%************************************************************************ +%* * + Tidying coercions +%* * +%************************************************************************ + +\begin{code} + +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go (Refl ty) = Refl (tidyType env ty) + go (TyConAppCo tc cos) = let args = map go cos + in args `seqList` TyConAppCo tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co) + where + (envp, tvp) = tidyTyVarBndr env tv + go (PredCo pco) = PredCo $! (go <$> pco) + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (AxiomInstCo con cos) = let args = tidyCos env cos + in args `seqList` AxiomInstCo con args + go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo d co) = NthCo d $! go co + go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) + +\end{code} %************************************************************************ %* * @@ -552,9 +586,9 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> False + MetaTv (SigTv _) _ -> False _ -> True - + isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of @@ -672,22 +706,19 @@ tcSplitForAllTys :: Type -> ([TyVar], Type) tcSplitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs - split _ (ForAllTy tv ty) tvs - | not (isCoVar tv) = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv) -tcIsForAllTy _ = False +tcIsForAllTy (ForAllTy {}) = True +tcIsForAllTy _ = False tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (ForAllTy tv ty) - | isCoVar tv = Just (coVarPred tv, ty) tcSplitPredFunTy_maybe (FunTy arg res) - | Just p <- tcSplitPredTy_maybe arg = Just (p, res) + | Just p <- splitPredTy_maybe arg = Just (p, res) tcSplitPredFunTy_maybe _ = Nothing @@ -837,13 +868,12 @@ tcSplitDFunTy ty -- coercion and class constraints; or (in the general NDP case) -- some other function argument split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty' - split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty split_dfun_args n ty = (n, ty) tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau - = case tcSplitPredTy_maybe tau of + = case splitPredTy_maybe tau of Just (ClassP clas tys) -> (clas, tys) _ -> pprPanic "tcSplitDFunHead" (ppr tau) @@ -886,60 +916,6 @@ tcInstHeadTyAppAllTyVars ty %* * %************************************************************************ -\begin{code} -evVarPred :: EvVar -> PredType -evVarPred var - = case tcSplitPredTy_maybe (varType var) of - Just pred -> pred - Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var)) - -tcSplitPredTy_maybe :: Type -> Maybe PredType - -- Returns Just for predicates only -tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty' -tcSplitPredTy_maybe (PredTy p) = Just p -tcSplitPredTy_maybe _ = Nothing - -predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique (ipNameName n) -predTyUnique (ClassP clas _) = getUnique clas -predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) -\end{code} - - ---------------------- Dictionary types --------------------------------- - -\begin{code} -mkClassPred :: Class -> [Type] -> PredType -mkClassPred clas tys = ClassP clas tys - -isClassPred :: PredType -> Bool -isClassPred (ClassP _ _) = True -isClassPred _ = False - -isTyVarClassPred :: PredType -> Bool -isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys -isTyVarClassPred _ = False - -getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) -getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) -getClassPredTys_maybe _ = Nothing - -getClassPredTys :: PredType -> (Class, [Type]) -getClassPredTys (ClassP clas tys) = (clas, tys) -getClassPredTys _ = panic "getClassPredTys" - -mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = mkPredTy (ClassP clas tys) - -isDictLikeTy :: Type -> Bool --- Note [Dictionary-like types] -isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' -isDictLikeTy (PredTy p) = isClassPred p -isDictLikeTy (TyConApp tc tys) - | isTupleTyCon tc = all isDictLikeTy tys -isDictLikeTy _ = False -\end{code} - Superclasses \begin{code} @@ -949,7 +925,7 @@ mkMinimalBySCs ptys = [ ploc | ploc <- ptys , ploc `not_in_preds` rec_scs ] where rec_scs = concatMap trans_super_classes ptys - not_in_preds p ps = null (filter (tcEqPred p) ps) + not_in_preds p ps = null (filter (eqPred p) ps) trans_super_classes (ClassP cls tys) = transSuperClasses cls tys trans_super_classes _other_pty = [] @@ -969,53 +945,6 @@ immSuperClasses cls tys where (tyvars,sc_theta,_,_) = classBigSig cls \end{code} -Note [Dictionary-like types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Being "dictionary-like" means either a dictionary type or a tuple thereof. -In GHC 6.10 we build implication constraints which construct such tuples, -and if we land up with a binding - t :: (C [a], Eq [a]) - t = blah -then we want to treat t as cheap under "-fdicts-cheap" for example. -(Implication constraints are normally inlined, but sadly not if the -occurrence is itself inside an INLINE function! Until we revise the -handling of implication constraints, that is.) This turned out to -be important in getting good arities in DPH code. Example: - - class C a - class D a where { foo :: a -> a } - instance C a => D (Maybe a) where { foo x = x } - - bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) - {-# INLINE bar #-} - bar x y = (foo (Just x), foo (Just y)) - -Then 'bar' should jolly well have arity 4 (two dicts, two args), but -we ended up with something like - bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... - in \x,y. <blah>) - -This is all a bit ad-hoc; eg it relies on knowing that implication -constraints build tuples. - ---------------------- Implicit parameters --------------------------------- - -\begin{code} -mkIPPred :: IPName Name -> Type -> PredType -mkIPPred ip ty = IParam ip ty - -isIPPred :: PredType -> Bool -isIPPred (IParam _ _) = True -isIPPred _ = False -\end{code} - ---------------------- Equality predicates --------------------------------- -\begin{code} -substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)] -substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty) - | (tv,ty) <- eq_spec] -\end{code} - %************************************************************************ %* * @@ -1037,17 +966,10 @@ isSigmaTy _ = False isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods --- NB: be sure to check for type with an equality predicate; hence isCoVar isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty -isOverloadedTy (FunTy a _) = isPredTy a -isOverloadedTy _ = False - -isPredTy :: Type -> Bool -- Belongs in TcType because it does - -- not look through newtypes, or predtypes (of course) -isPredTy ty | Just ty' <- tcView ty = isPredTy ty' -isPredTy (PredTy _) = True -isPredTy _ = False +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False \end{code} \begin{code} @@ -1109,14 +1031,9 @@ tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg -tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar) - `unionVarSet` tcTyVarsOfTyVar tyvar +tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar -- We do sometimes quantify over skolem TcTyVars -tcTyVarsOfTyVar :: TcTyVar -> TyVarSet -tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv) - | otherwise = emptyVarSet - tcTyVarsOfTypes :: [Type] -> TyVarSet tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys @@ -1126,61 +1043,6 @@ tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2 \end{code} -Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! -Here's the example that Ralf Laemmel showed me: - foo :: (forall a. C u a -> C u a) -> u - mappend :: Monoid u => u -> u -> u - - bar :: Monoid u => u - bar = foo (\t -> t `mappend` t) -We have to generalise at the arg to f, and we don't -want to capture the constraint (Monad (C u a)) because -it appears to mention a. Pretty silly, but it was useful to him. - -exactTyVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It's also used in the -smart-app checking code --- see TcExpr.tcIdApp - -On the other hand, consider a *top-level* definition - f = (\x -> x) :: T a -> T a -If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then -if we have an application like (f "x") we get a confusing error message -involving Any. So the conclusion is this: when generalising - - at top level use tyVarsOfType - - in nested bindings use exactTyVarsOfType -See Trac #1813 for example. - -\begin{code} -exactTyVarsOfType :: TcType -> TyVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyVarsOfType ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = unitVarSet tv - go (TyConApp _ tys) = exactTyVarsOfTypes tys - go (PredTy ty) = go_pred ty - go (FunTy arg res) = go arg `unionVarSet` go res - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar - `unionVarSet` go_tv tyvar - - go_pred (IParam _ ty) = go ty - go_pred (ClassP _ tys) = exactTyVarsOfTypes tys - go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 - - go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar) - | otherwise = emptyVarSet - -exactTyVarsOfTypes :: [TcType] -> TyVarSet -exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys -\end{code} - Find the free tycons and classes of a type. This is used in the front end of the compiler. @@ -1213,6 +1075,28 @@ orphNamesOfDFunHead :: Type -> NameSet orphNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of (_, _, head_ty) -> orphNamesOfType head_ty + +orphNamesOfCo :: Coercion -> NameSet +orphNamesOfCo (Refl ty) = orphNamesOfType ty +orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos +orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co +orphNamesOfCo (PredCo p) = Foldable.foldr (unionNameSets . orphNamesOfCo) + emptyNameSet p +orphNamesOfCo (CoVarCo _) = emptyNameSet +orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos +orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2 +orphNamesOfCo (SymCo co) = orphNamesOfCo co +orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 +orphNamesOfCo (NthCo _ co) = orphNamesOfCo co +orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty + +orphNamesOfCos :: [Coercion] -> NameSet +orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet + +orphNamesOfCoCon :: CoAxiom -> NameSet +orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 }) + = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2 \end{code} @@ -1227,7 +1111,7 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI) +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion) -- (isIOType t) returns Just (IO,t',co) -- if co : t ~ IO t' -- returns Nothing otherwise @@ -1238,7 +1122,7 @@ tcSplitIOType_maybe ty Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey - -> Just (io_tycon, io_res_ty, IdCo ty) + -> Just (io_tycon, io_res_ty, mkReflCo ty) Just (tc, tys) | not (isRecursiveTyCon tc) @@ -1246,7 +1130,7 @@ tcSplitIOType_maybe ty -- Newtypes that require a coercion are ok -> case tcSplitIOType_maybe ty of Nothing -> Nothing - Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2) + Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2) _ -> Nothing diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 4fc50b3325..0dfe3941c5 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -28,7 +28,7 @@ module TcUnify ( import HsSyn import TypeRep import CoreUtils( mkPiTypes ) -import TcErrors ( unifyCtxt ) +import TcErrors ( unifyCtxt ) import TcMType import TcIface import TcRnMonad @@ -44,7 +44,6 @@ import VarEnv import Name import ErrUtils import BasicTypes - import Maybes ( allMaybes ) import Util import Outputable @@ -103,7 +102,7 @@ expected type, becuase it expects that to have been done already matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] -> Arity -> TcRhoType - -> TcM (CoercionI, [TcSigmaType], TcRhoType) + -> TcM (Coercion, [TcSigmaType], TcRhoType) -- If matchExpectFunTys n ty = (co, [t1,..,tn], ty_r) -- then co : ty ~ (t1 -> ... -> tn -> ty_r) @@ -122,7 +121,7 @@ matchExpectedFunTys herald arity orig_ty -- then co : ty ~ t1 -> .. -> tn -> ty_r go n_req ty - | n_req == 0 = return (IdCo ty, [], ty) + | n_req == 0 = return (mkReflCo ty, [], ty) go n_req ty | Just ty' <- tcView ty = go n_req ty' @@ -130,7 +129,7 @@ matchExpectedFunTys herald arity orig_ty go n_req (FunTy arg_ty res_ty) | not (isPredTy arg_ty) = do { (coi, tys, ty_r) <- go (n_req-1) res_ty - ; return (mkFunTyCoI (IdCo arg_ty) coi, arg_ty:tys, ty_r) } + ; return (mkFunCo (mkReflCo arg_ty) coi, arg_ty:tys, ty_r) } go _ (TyConApp tc _) -- A common case | not (isSynFamilyTyCon tc) @@ -173,14 +172,14 @@ matchExpectedFunTys herald arity orig_ty \begin{code} ---------------------- -matchExpectedListTy :: TcRhoType -> TcM (CoercionI, TcRhoType) +matchExpectedListTy :: TcRhoType -> TcM (Coercion, TcRhoType) -- Special case for lists matchExpectedListTy exp_ty = do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty ; return (coi, elt_ty) } ---------------------- -matchExpectedPArrTy :: TcRhoType -> TcM (CoercionI, TcRhoType) +matchExpectedPArrTy :: TcRhoType -> TcM (Coercion, TcRhoType) -- Special case for parrs matchExpectedPArrTy exp_ty = do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty @@ -189,7 +188,7 @@ matchExpectedPArrTy exp_ty ---------------------- matchExpectedTyConApp :: TyCon -- T :: k1 -> ... -> kn -> * -> TcRhoType -- orig_ty - -> TcM (CoercionI, -- T a b c ~ orig_ty + -> TcM (Coercion, -- T a b c ~ orig_ty [TcSigmaType]) -- Element types, a b c -- It's used for wired-in tycons, so we call checkWiredInTyCon @@ -200,7 +199,7 @@ matchExpectedTyConApp tc orig_ty = do { checkWiredInTyCon tc ; go (tyConArity tc) orig_ty [] } where - go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (CoercionI, [TcSigmaType]) + go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (Coercion, [TcSigmaType]) -- If go n ty tys = (co, [t1..tn] ++ tys) -- then co : T t1..tn ~ ty @@ -217,12 +216,12 @@ matchExpectedTyConApp tc orig_ty go n_req ty@(TyConApp tycon args) tys | tc == tycon = ASSERT( n_req == length args) -- ty::* - return (IdCo ty, args ++ tys) + return (mkReflCo ty, args ++ tys) go n_req (AppTy fun arg) tys | n_req > 0 = do { (coi, args) <- go (n_req - 1) fun (arg : tys) - ; return (mkAppTyCoI coi (IdCo arg), args) } + ; return (mkAppCo coi (mkReflCo arg), args) } go n_req ty tys = defer n_req ty tys @@ -236,7 +235,7 @@ matchExpectedTyConApp tc orig_ty ---------------------- matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (CoercionI, -- m a ~ orig_ty + -> TcM (Coercion, -- m a ~ orig_ty (TcSigmaType, TcSigmaType)) -- Returns m, a -- If the incoming type is a mutable type variable of kind k, then -- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. @@ -248,7 +247,7 @@ matchExpectedAppTy orig_ty | Just ty' <- tcView ty = go ty' | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (IdCo orig_ty, (fun_ty, arg_ty)) + = return (mkReflCo orig_ty, (fun_ty, arg_ty)) go (TyVarTy tv) | ASSERT( isTcTyVar tv) isMetaTyVar tv @@ -306,14 +305,14 @@ tcSubType origin ctxt ty_actual ty_expected <- tcGen ctxt ty_expected $ \ _ sk_rho -> do { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual ; coi <- unifyType in_rho sk_rho - ; return (coiToHsWrapper coi <.> in_wrap) } + ; return (coToHsWrapper coi <.> in_wrap) } ; return (sk_wrap <.> inst_wrap) } | otherwise -- Urgh! It seems deeply weird to have equality -- when actual is not a polytype, and it makes a big -- difference e.g. tcfail104 = do { coi <- unifyType ty_actual ty_expected - ; return (coiToHsWrapper coi) } + ; return (coToHsWrapper coi) } tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind @@ -325,7 +324,7 @@ tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) tcWrapResult expr actual_ty res_ty = do { coi <- unifyType actual_ty res_ty -- Both types are deeply skolemised - ; return (mkHsWrapCoI coi expr) } + ; return (mkHsWrapCo coi expr) } ----------------------------------- wrapFunResCoercion @@ -451,18 +450,18 @@ non-exported generic functions. \begin{code} --------------- -unifyType :: TcTauType -> TcTauType -> TcM CoercionI +unifyType :: TcTauType -> TcTauType -> TcM Coercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 unifyType ty1 ty2 = uType [] ty1 ty2 --------------- -unifyPred :: PredType -> PredType -> TcM CoercionI +unifyPred :: PredType -> PredType -> TcM Coercion -- Actual and expected types unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2 --------------- -unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI] +unifyTheta :: TcThetaType -> TcThetaType -> TcM [Coercion] -- Actual and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) @@ -513,7 +512,7 @@ uType, uType_np, uType_defer :: [EqOrigin] -> TcType -- ty1 is the *actual* type -> TcType -- ty2 is the *expected* type - -> TcM CoercionI + -> TcM Coercion -------------- -- It is always safe to defer unification to the main constraint solver @@ -529,7 +528,7 @@ uType_defer (item : origin) ty1 ty2 ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin, doc]) - ; return $ ACo $ mkTyVarTy co_var } + ; return $ mkCoVarCo co_var } uType_defer [] _ _ = panic "uType_defer" @@ -545,15 +544,15 @@ uType_np origin orig_ty1 orig_ty2 [ sep [ ppr orig_ty1, text "~", ppr orig_ty2] , ppr origin] ; coi <- go orig_ty1 orig_ty2 - ; case coi of - ACo co -> traceTc "u_tys yields coercion:" (ppr co) - IdCo _ -> traceTc "u_tys yields no coercion" empty + ; if isReflCo coi + then traceTc "u_tys yields no coercion" empty + else traceTc "u_tys yields coercion:" (ppr coi) ; return coi } where bale_out :: [EqOrigin] -> TcM a bale_out origin = failWithMisMatch origin - go :: TcType -> TcType -> TcM CoercionI + go :: TcType -> TcType -> TcM Coercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -579,24 +578,14 @@ uType_np origin orig_ty1 orig_ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - -- Predicates go (PredTy p1) (PredTy p2) = uPred origin p1 p2 - -- Coercion functions: (t1a ~ t1b) => t1c ~ (t2a ~ t2b) => t2c - go ty1 ty2 - | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe ty1, - Just (t2a,t2b,t2c) <- splitCoPredTy_maybe ty2 - = do { co1 <- uType origin t1a t2a - ; co2 <- uType origin t1b t2b - ; co3 <- uType origin t1c t2c - ; return $ mkCoPredCoI co1 co2 co3 } - -- Functions (or predicate functions) just check the two parts go (FunTy fun1 arg1) (FunTy fun2 arg2) = do { coi_l <- uType origin fun1 fun2 ; coi_r <- uType origin arg1 arg2 - ; return $ mkFunTyCoI coi_l coi_r } + ; return $ mkFunCo coi_l coi_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) @@ -608,20 +597,20 @@ uType_np origin orig_ty1 orig_ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2 -- See Note [TyCon app] = do { cois <- uList origin uType tys1 tys2 - ; return $ mkTyConAppCoI tc1 cois } + ; return $ mkTyConAppCo tc1 cois } -- See Note [Care with type applications] go (AppTy s1 t1) ty2 | Just (s2,t2) <- tcSplitAppTy_maybe ty2 = do { coi_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] ; coi_t <- uType origin t1 t2 - ; return $ mkAppTyCoI coi_s coi_t } + ; return $ mkAppCo coi_s coi_t } go ty1 (AppTy s2 t2) | Just (s1,t1) <- tcSplitAppTy_maybe ty1 = do { coi_s <- uType_np origin s1 s2 ; coi_t <- uType origin t1 t2 - ; return $ mkAppTyCoI coi_s coi_t } + ; return $ mkAppCo coi_s coi_t } go ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 @@ -630,7 +619,7 @@ uType_np origin orig_ty1 orig_ty2 -- Anything else fails go _ _ = bale_out origin -unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI +unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM Coercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 @@ -639,9 +628,8 @@ unifySigmaTy origin ty1 ty2 -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs in_scope = mkInScopeSet (mkVarSet skol_tvs) - phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 - phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 --- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 + phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 + phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 ; ((coi, _untch), lie) <- captureConstraints $ captureUntouchables $ @@ -656,23 +644,24 @@ unifySigmaTy origin ty1 ty2 (failWithMisMatch origin) -- ToDo: give details from bad_lie ; emitConstraints lie - ; return (foldr mkForAllTyCoI coi skol_tvs) } + ; return (foldr mkForAllCo coi skol_tvs) } ---------- -uPred :: [EqOrigin] -> PredType -> PredType -> TcM CoercionI +uPred :: [EqOrigin] -> PredType -> PredType -> TcM Coercion uPred origin (IParam n1 t1) (IParam n2 t2) | n1 == n2 = do { coi <- uType origin t1 t2 - ; return $ mkIParamPredCoI n1 coi } + ; return $ mkPredCo $ IParam n1 coi } uPred origin (ClassP c1 tys1) (ClassP c2 tys2) | c1 == c2 = do { cois <- uList origin uType tys1 tys2 -- Guaranteed equal lengths because the kinds check - ; return $ mkClassPPredCoI c1 cois } + ; return $ mkPredCo $ ClassP c1 cois } + uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b) - = do { coia <- uType origin ty1a ty2a - ; coib <- uType origin ty1b ty2b - ; return $ mkEqPredCoI coia coib } + = do { coa <- uType origin ty1a ty2a + ; cob <- uType origin ty1b ty2b + ; return $ mkPredCo $ EqPred coa cob } uPred origin _ _ = failWithMisMatch origin @@ -816,7 +805,7 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM CoercionI +uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM Coercion uVar origin swapped tv1 ty2 = do { traceTc "uVar" (vcat [ ppr origin , ppr swapped @@ -834,13 +823,13 @@ uUnfilledVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTauType -- Type 2 - -> TcM CoercionI + -> TcM Coercion -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar -- It might be a skolem, or untouchable, or meta uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) | tv1 == tv2 -- Same type variable => no-op - = return (IdCo (mkTyVarTy tv1)) + = return (mkReflCo (mkTyVarTy tv1)) | otherwise -- Distinct type variables = do { lookup2 <- lookupTcTyVar tv2 @@ -874,7 +863,7 @@ uUnfilledVars :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTyVar -> TcTyVarDetails -- Tyvar 2 - -> TcM CoercionI + -> TcM Coercion -- Invarant: The type variables are distinct, -- Neither is filled in yet @@ -1053,10 +1042,10 @@ lookupTcTyVar tyvar details = ASSERT2( isTcTyVar tyvar, ppr tyvar ) tcTyVarDetails tyvar -updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM CoercionI +updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM Coercion updateMeta tv1 ref1 ty2 = do { writeMetaTyVarRef tv1 ref1 ty2 - ; return (IdCo ty2) } + ; return (mkReflCo ty2) } \end{code} Note [Unifying untouchables] diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index 244f0cb19b..e7ad4181fc 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -2,10 +2,10 @@ module TcUnify where import TcType ( TcTauType ) import TcRnTypes( TcM ) -import Coercion (CoercionI) +import Coercion (Coercion) -- This boot file exists only to tie the knot between -- TcUnify and TcSimplify -unifyType :: TcTauType -> TcTauType -> TcM CoercionI +unifyType :: TcTauType -> TcTauType -> TcM Coercion \end{code} diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index faab463044..3fc8466d05 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -7,15 +7,9 @@ -- as used in System FC. See 'CoreSyn.Expr' for -- more on System FC and how coercions fit into it. -- --- Coercions are represented as types, and their kinds tell what types the --- coercion works on. The coercion kind constructor is a special TyCon that --- must always be saturated, like so: --- --- > typeKind (symCoercion type) :: TyConApp CoTyCon{...} [type, type] module Coercion ( -- * Main data type - Coercion, Kind, - typeKind, + Coercion(..), Var, CoVar, -- ** Deconstructing Kinds kindFunResult, kindAppResult, synTyConResKind, @@ -24,237 +18,460 @@ module Coercion ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, - isCoSuperKind, isSuperKind, isCoercionKind, + isSuperKind, isCoercionKind, mkArrowKind, mkArrowKinds, isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind, isSubKindCon, - mkCoKind, mkCoPredTy, coVarKind, coVarKind_maybe, - coercionKind, coercionKinds, isIdentityCoercion, - - -- ** Equality predicates - isEqPred, mkEqPred, getEqPredTys, isEqPredTy, - - -- ** Coercion transformations - mkCoercion, - mkSymCoercion, mkTransCoercion, - mkLeftCoercion, mkRightCoercion, - mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion, - mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion, - mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion, - mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion, - - mkClassPPredCo, mkIParamPredCo, mkEqPredCo, - mkCoVarCoercion, mkCoPredCo, + mkCoType, coVarKind, coVarKind_maybe, + coercionType, coercionKind, coercionKinds, isReflCo, - - unsafeCoercionTyCon, symCoercionTyCon, - transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn - csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon, + -- ** Constructing coercions + mkReflCo, mkCoVarCo, + mkAxInstCo, mkPiCo, mkPiCos, + mkSymCo, mkTransCo, mkNthCo, + mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, + mkForAllCo, mkUnsafeCo, + mkNewTypeCo, mkFamInstCo, + mkPredCo, -- ** Decomposition - decompLR_maybe, decompCsel_maybe, decompInst_maybe, splitCoPredTy_maybe, splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo, - + getCoVar_maybe, + + splitTyConAppCo_maybe, + splitAppCo_maybe, + splitForAllCo_maybe, + + -- ** Coercion variables + mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar, + isEmptyCvSubst, zapCvSubstEnv, getCvInScope, + substCo, substCos, substCoVar, substCoVars, + substCoWithTy, substCoWithTys, + cvTvSubst, tvCvSubst, zipOpenCvSubst, + substTy, extendTvSubst, + substTyVarBndr, substCoVarBndr, + + -- ** Lifting + liftCoMatch, liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, + -- ** Comparison coreEqCoercion, coreEqCoercion2, - -- * CoercionI - CoercionI(..), - isIdentityCoI, - mkSymCoI, mkTransCoI, - mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI, - mkForAllTyCoI, - fromCoI, - mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI, mkCoPredCoI + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + -- * Other + applyCo, coVarPred + ) where #include "HsVersions.h" +import Unify ( MatchEnv(..), ruleMatchTyX, matchList ) import TypeRep -import Type +import qualified Type +import Type hiding( substTy, substTyVarBndr, extendTvSubst ) +import Kind import TyCon -import Class import Var import VarEnv import VarSet -import Name -import PrelNames +import UniqFM ( minusUFM ) +import Maybes ( orElse ) +import Name ( Name, NamedThing(..), nameUnique ) +import OccName ( isSymOcc ) import Util import BasicTypes import Outputable +import Unique +import Pair +import PrelNames( funTyConKey ) +import Control.Applicative +import Data.Traversable (traverse, sequenceA) +import Control.Arrow (second) import FastString + +import qualified Data.Data as Data hiding ( TyCon ) \end{code} %************************************************************************ %* * - Functions over Kinds + Coercions %* * %************************************************************************ \begin{code} --- | Essentially 'funResultTy' on kinds -kindFunResult :: Kind -> Kind -kindFunResult k = funResultTy k - -kindAppResult :: Kind -> [arg] -> Kind -kindAppResult k [] = k -kindAppResult k (_:as) = kindAppResult (kindFunResult k) as - --- | Essentially 'splitFunTys' on kinds -splitKindFunTys :: Kind -> ([Kind],Kind) -splitKindFunTys k = splitFunTys k - -splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) -splitKindFunTy_maybe = splitFunTy_maybe - --- | Essentially 'splitFunTysN' on kinds -splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) -splitKindFunTysN k = splitFunTysN k - --- | Find the result 'Kind' of a type synonym, --- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, --- but they'd always return '*', so we never need to ask -synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool -isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool - -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey - -isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc -isOpenTypeKind _ = False - -isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey - -isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc -isUbxTupleKind _ = False - -isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey - -isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc -isArgTypeKind _ = False - -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey - -isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc -isUnliftedTypeKind _ = False - -isSubOpenTypeKind :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) -isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) - ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) - False -isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True -isSubOpenTypeKind other = ASSERT( isKind other ) False - -- This is a conservative answer - -- It matters in the call to isSubKind in - -- checkExpectedKind. - -isSubArgTypeKindCon kc - | isUnliftedTypeKindCon kc = True - | isLiftedTypeKindCon kc = True - | isArgTypeKindCon kc = True - | otherwise = False - -isSubArgTypeKind :: Kind -> Bool --- ^ True of any sub-kind of ArgTypeKind -isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc -isSubArgTypeKind _ = False - --- | Is this a super-kind (i.e. a type-of-kinds)? -isSuperKind :: Type -> Bool -isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc -isSuperKind _ = False - --- | Is this a kind (i.e. a type-of-types)? -isKind :: Kind -> Bool -isKind k = isSuperKind (typeKind k) - -isSubKind :: Kind -> Kind -> Bool --- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) -isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2')) - = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2' -isSubKind _ _ = False - -eqKind :: Kind -> Kind -> Bool -eqKind = tcEqType - -isSubKindCon :: TyCon -> TyCon -> Bool --- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ -isSubKindCon kc1 kc2 - | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True - | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True - | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True - | isOpenTypeKindCon kc2 = True - -- we already know kc1 is not a fun, its a TyCon - | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True - | otherwise = False - -defaultKind :: Kind -> Kind --- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more --- information on what that means - --- When we generalise, we make generic type variables whose kind is --- simple (* or *->* etc). So generic type variables (other than --- built-in constants like 'error') always have simple kinds. This is important; --- consider --- f x = True --- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::??). a -> Bool --- because that would allow a call like (f 3#) as well as (f True), ---and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k - | isSubOpenTypeKind k = liftedTypeKind - | isSubArgTypeKind k = liftedTypeKind - | otherwise = k +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. +data Coercion + -- These ones mirror the shape of types + = 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. + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + | TyConAppCo TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + + | AppCo Coercion Coercion -- lift AppTy + + -- See Note [Forall coercions] + | ForAllCo TyVar Coercion -- forall a. g + | PredCo (Pred Coercion) -- (g1~g2) etc + + -- These are special + | CoVarCo CoVar + | AxiomInstCo CoAxiom [Coercion] -- The coercion arguments always *precisely* + -- saturate arity of CoAxiom. + -- See [Coercion axioms applied to coercions] + | UnsafeCo Type Type + | SymCo Coercion + | TransCo Coercion Coercion + + -- These are destructors + | NthCo Int Coercion -- Zero-indexed + | InstCo Coercion Type + deriving (Data.Data, Data.Typeable) \end{code} +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Coercions have the following invariant + Refl 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 [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 [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky. +Currently, the situation is as follows: + + ForAllCo TyVar Coercion + +represents a coercion between polymorphic types, with the rule + + v : k g : t1 ~ t2 + ---------------------------------------------- + ForAllCo v g : (all v:k . t1) ~ (all v:k . t2) + +Note that it's only necessary to coerce between polymorphic types +where the type variables have identical kinds, because equality on +kinds is trivial. + + ForAllCoCo Coercion Coercion Coercion + +represents a coercion between types abstracted over equality proofs, +which we might more suggestively write as + + ForAllCoCo (_:Coercion~Coercion) Coercion + +The rule is + + g1 : t1 ~ t1' g2 : t2 ~ t2' g3 : t3 ~ t3' + ------------------------------------------------------------------ + ForAllCoCo g1 g2 g3 : ( (t1 ~ t2) => t3 ) ~ ( (t1' ~ t2') => t3' ) + +There are several things to note. First, we don't need to bind a +variable, since coercion variables do not appear in types. Second, +note that here we DO need to convert between "kinds" (the types of the +required coercions). + +In the future, if we collapse the type and kind levels and add a bit +more dependency, we will need something like + + | ForAllCo TyVar Coercion Coercion + | ForAllCoCo CoVar Coercion Coercion Coercion + +The addition of the extra coercion in the first case handles +converting between possibly different kinds; the addition of a CoVar +in the second case is needed since now types may mention coercion +variables (in casts). + + %************************************************************************ %* * - Coercions +\subsection{Coercion variables} +%* * +%************************************************************************ + +\begin{code} +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +isCoVar :: Var -> Bool +isCoVar v = isCoVarType (varType v) + +isCoVarType :: Type -> Bool +isCoVarType = isEqPredTy +\end{code} + + +\begin{code} +tyCoVarsOfCo :: Coercion -> VarSet +-- Extracts type and coercion variables from a coercion +tyCoVarsOfCo (Refl ty) = tyVarsOfType ty +tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv +tyCoVarsOfCo (PredCo pred) = varsOfPred tyCoVarsOfCo pred +tyCoVarsOfCo (CoVarCo v) = unitVarSet v +tyCoVarsOfCo (AxiomInstCo _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co +tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty + +tyCoVarsOfCos :: [Coercion] -> VarSet +tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos + +coVarsOfCo :: Coercion -> VarSet +-- Extract *coerction* variables only. Tiresome to repeat the code, but easy. +coVarsOfCo (Refl _) = emptyVarSet +coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos +coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (ForAllCo _ co) = coVarsOfCo co +coVarsOfCo (PredCo pred) = varsOfPred coVarsOfCo pred +coVarsOfCo (CoVarCo v) = unitVarSet v +coVarsOfCo (AxiomInstCo _ cos) = coVarsOfCos cos +coVarsOfCo (UnsafeCo _ _) = emptyVarSet +coVarsOfCo (SymCo co) = coVarsOfCo co +coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (InstCo co _) = coVarsOfCo co + +coVarsOfCos :: [Coercion] -> VarSet +coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos) +coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 +coercionSize (ForAllCo _ co) = 1 + coercionSize co +coercionSize (PredCo pred) = predSize coercionSize pred +coercionSize (CoVarCo _) = 1 +coercionSize (AxiomInstCo _ cos) = 1 + sum (map coercionSize cos) +coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty +\end{code} + +%************************************************************************ %* * + Pretty-printing coercions +%* * %************************************************************************ +@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@ +function is defined to use this. @pprParendCo@ is the same, except it +puts parens around the type, except for the atomic cases. +@pprParendCo@ works just by setting the initial context precedence +very high. \begin{code} --- | A 'Coercion' represents a 'Type' something should be coerced to. -type Coercion = Type +instance Outputable Coercion where + ppr = pprCo + +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = ppr_co TopPrec co +pprParendCo co = ppr_co TyConPrec co + +ppr_co :: Prec -> Coercion -> SDoc +ppr_co _ (Refl ty) = angles (ppr ty) + +ppr_co p co@(TyConAppCo tc cos) + | tc `hasKey` funTyConKey = ppr_fun_co p co + | otherwise = maybeParen p TyConPrec $ + pprTcApp p ppr_co tc cos + +ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ + pprCo co1 <+> ppr_co TyConPrec co2 + +ppr_co p co@(ForAllCo {}) = ppr_forall_co p co +ppr_co _ (PredCo pred) = pprPred ppr_co pred --- | A 'CoercionKind' is always of form @ty1 ~ ty2@ and indicates the --- types that a 'Coercion' will work on. -type CoercionKind = Kind +ppr_co _ (CoVarCo cv) + | isSymOcc (getOccName cv) = parens (ppr cv) + | otherwise = ppr cv ------------------------------- +ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos + + +ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 + <+> ptext (sLit ";") + <+> ppr_co FunPrec co2 +ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ + pprParendCo co <> ptext (sLit "@") <> pprType ty + +ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2] +ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co] + + +angles :: SDoc -> SDoc +angles p = char '<' <> p <> char '>' + +ppr_fun_co :: Prec -> Coercion -> SDoc +ppr_fun_co p co = pprArrowChain p (split co) + where + split (TyConAppCo f [arg,res]) + | f `hasKey` funTyConKey + = ppr_co FunPrec arg : split res + split co = [ppr_co TopPrec co] + +ppr_forall_co :: Prec -> Coercion -> SDoc +ppr_forall_co p ty + = maybeParen p FunPrec $ + sep [pprForAll tvs, pprThetaArrow ppr_co ctxt, ppr_co TopPrec tau] + where + (tvs, rho) = split1 [] ty + (ctxt, tau) = split2 [] rho + + -- We need to be extra careful here as equality constraints will occur as + -- type variables with an equality kind. So, while collecting quantified + -- variables, we separate the coercion variables out and turn them into + -- equality predicates. + split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) + + split2 ps (TyConAppCo tc [PredCo p, co]) + | tc `hasKey` funTyConKey = split2 (p:ps) co + split2 ps co = (reverse ps, co) +\end{code} + + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ --- | This breaks a 'Coercion' with 'CoercionKind' @T A B C ~ T D E F@ into +\begin{code} +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: -- --- > decomposeCo 3 c = [right (left (left c)), right (left c), right c] +-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] decomposeCo :: Arity -> Coercion -> [Coercion] -decomposeCo n co - = go n co [] - where - go 0 _ cos = cos - go n co cos = go (n-1) (mkLeftCoercion co) - (mkRightCoercion co : cos) - +decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ] + +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe (Refl ty) = (fmap . second . map) Refl (splitTyConApp_maybe ty) +splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos) +splitTyConAppCo_maybe _ = Nothing + +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2) +splitAppCo_maybe (TyConAppCo tc cos) + | not (null cos) = Just (mkTyConAppCo tc (init cos), last cos) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl +splitAppCo_maybe (Refl ty) + | Just (ty1, ty2) <- splitAppTy_maybe ty = Just (Refl ty1, Refl ty2) + | otherwise = Nothing +splitAppCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) +splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co) +splitForAllCo_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff +coVarPred :: CoVar -> PredType +coVarPred cv + = ASSERT( isCoVar cv ) + case splitPredTy_maybe (varType cv) of + Just pred -> pred + other -> pprPanic "coVarPred" (ppr cv $$ ppr other) + coVarKind :: CoVar -> (Type,Type) -- c :: t1 ~ t2 coVarKind cv = case coVarKind_maybe cv of @@ -262,31 +479,12 @@ coVarKind cv = case coVarKind_maybe cv of Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv)) coVarKind_maybe :: CoVar -> Maybe (Type,Type) -coVarKind_maybe cv = splitCoKind_maybe (tyVarKind cv) - --- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'. --- Panics if the argument is not a valid 'CoercionKind' -splitCoKind_maybe :: Kind -> Maybe (Type, Type) -splitCoKind_maybe co | Just co' <- kindView co = splitCoKind_maybe co' -splitCoKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2) -splitCoKind_maybe _ = Nothing +coVarKind_maybe cv = splitEqPredTy_maybe (varType cv) --- | Makes a 'CoercionKind' from two types: the types whose equality +-- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' -mkCoKind :: Type -> Type -> CoercionKind -mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2) - --- | (mkCoPredTy s t r) produces the type: (s~t) => r -mkCoPredTy :: Type -> Type -> Type -> Type -mkCoPredTy s t r = ASSERT( not (co_var `elemVarSet` tyVarsOfType r) ) - ForAllTy co_var r - where - co_var = mkWildCoVar (mkCoKind s t) - -mkCoPredCo :: Coercion -> Coercion -> Coercion -> Coercion --- Creates a coercion between (s1~t1) => r1 and (s2~t2) => r2 -mkCoPredCo = mkCoPredTy - +mkCoType :: Type -> Type -> Type +mkCoType ty1 ty2 = PredTy (EqPred ty1 ty2) splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type) splitCoPredTy_maybe ty @@ -297,25 +495,13 @@ splitCoPredTy_maybe ty | otherwise = Nothing --- | Tests whether a type is just a type equality predicate -isEqPredTy :: Type -> Bool -isEqPredTy (PredTy pred) = isEqPred pred -isEqPredTy _ = False - --- | Creates a type equality predicate -mkEqPred :: (Type, Type) -> PredType -mkEqPred (ty1, ty2) = EqPred ty1 ty2 - --- | Splits apart a type equality predicate, if the supplied 'PredType' is one. --- Panics otherwise -getEqPredTys :: PredType -> (Type,Type) -getEqPredTys (EqPred ty1 ty2) = (ty1, ty2) -getEqPredTys other = pprPanic "getEqPredTys" (ppr other) - -isIdentityCoercion :: Coercion -> Bool -isIdentityCoercion co - = case coercionKind co of - (t1,t2) -> t1 `coreEqType` t2 +isReflCo :: Coercion -> Bool +isReflCo (Refl {}) = True +isReflCo _ = False + +isReflCo_maybe :: Coercion -> Maybe Type +isReflCo_maybe (Refl ty) = Just ty +isReflCo_maybe _ = Nothing \end{code} %************************************************************************ @@ -324,236 +510,157 @@ isIdentityCoercion co %* * %************************************************************************ -Coercion kind and type mk's (make saturated TyConApp CoercionTyCon{...} args) - \begin{code} --- | Make a coercion from the specified coercion 'TyCon' and the 'Type' arguments to --- that coercion. Try to use the @mk*Coercion@ family of functions instead of using this function --- if possible -mkCoercion :: TyCon -> [Type] -> Coercion -mkCoercion coCon args = ASSERT( tyConArity coCon == length args ) - TyConApp coCon args +mkCoVarCo :: CoVar -> Coercion +mkCoVarCo cv + | ty1 `eqType` ty2 = Refl ty1 + | otherwise = CoVarCo cv + where + (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv -mkCoVarCoercion :: CoVar -> Coercion -mkCoVarCoercion cv = mkTyVarTy cv +mkReflCo :: Type -> Coercion +mkReflCo = Refl --- | Apply a 'Coercion' to another 'Coercion', which is presumably a --- 'Coercion' constructor of some kind -mkAppCoercion :: Coercion -> Coercion -> Coercion -mkAppCoercion co1 co2 = mkAppTy co1 co2 +mkAxInstCo :: CoAxiom -> [Type] -> Coercion +mkAxInstCo ax tys + | arity == n_tys = AxiomInstCo ax rtys + | otherwise = ASSERT( arity < n_tys ) + foldl AppCo (AxiomInstCo ax (take arity rtys)) + (drop arity rtys) + where + n_tys = length tys + arity = coAxiomArity ax + rtys = map Refl tys + +-- | Apply a 'Coercion' to another 'Coercion'. +mkAppCo :: Coercion -> Coercion -> Coercion +mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2) +mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co]) +mkAppCo (TyConAppCo tc cos) co = TyConAppCo tc (cos ++ [co]) +mkAppCo co1 co2 = AppCo co1 co2 +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs. -- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCoercion' -mkAppsCoercion :: Coercion -> [Coercion] -> Coercion -mkAppsCoercion co1 tys = foldl mkAppTy co1 tys +-- See also 'mkAppCo' +mkAppCos :: Coercion -> [Coercion] -> Coercion +mkAppCos co1 tys = foldl mkAppCo co1 tys -- | Apply a type constructor to a list of coercions. -mkTyConCoercion :: TyCon -> [Coercion] -> Coercion -mkTyConCoercion con cos = mkTyConApp con cos +mkTyConAppCo :: TyCon -> [Coercion] -> Coercion +mkTyConAppCo tc cos + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos + = mkAppCos (liftCoSubst (mkTopCvSubst tv_co_prs) rhs_ty) leftover_cos + + | Just tys <- traverse isReflCo_maybe cos + = Refl (mkTyConApp tc tys) -- See Note [Refl invariant] + + | otherwise = TyConAppCo tc cos -- | Make a function 'Coercion' between two other 'Coercion's -mkFunCoercion :: Coercion -> Coercion -> Coercion -mkFunCoercion co1 co2 = mkFunTy co1 co2 -- NB: Handles correctly the forall for eqpreds! +mkFunCo :: Coercion -> Coercion -> Coercion +mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2] -- | Make a 'Coercion' which binds a variable within an inner 'Coercion' -mkForAllCoercion :: Var -> Coercion -> Coercion +mkForAllCo :: Var -> Coercion -> Coercion -- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) -mkForAllCoercion tv co = ASSERT ( isTyCoVar tv ) mkForAllTy tv co +mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty) +mkForAllCo tv co = ASSERT ( isTyVar tv ) ForAllCo tv co +mkPredCo :: Pred Coercion -> Coercion +mkPredCo pred_co + = case traverse isReflCo_maybe pred_co of + Just pred_ty -> Refl (PredTy pred_ty) + Nothing -> PredCo pred_co ------------------------------- -mkSymCoercion :: Coercion -> Coercion --- ^ Create a symmetric version of the given 'Coercion' that asserts equality --- between the same types but in the other "direction", so a kind of @t1 ~ t2@ --- becomes the kind @t2 ~ t1@. -mkSymCoercion g = mkCoercion symCoercionTyCon [g] - -mkTransCoercion :: Coercion -> Coercion -> Coercion --- ^ Create a new 'Coercion' by exploiting transitivity on the two given 'Coercion's. -mkTransCoercion g1 g2 = mkCoercion transCoercionTyCon [g1, g2] - -mkLeftCoercion :: Coercion -> Coercion --- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of --- the "functions" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then: --- --- > mkLeftCoercion c :: f ~ g -mkLeftCoercion co = mkCoercion leftCoercionTyCon [co] - -mkRightCoercion :: Coercion -> Coercion --- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of --- the "arguments" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then: --- --- > mkLeftCoercion c :: x ~ y -mkRightCoercion co = mkCoercion rightCoercionTyCon [co] - -mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion :: Coercion -> Coercion -mkCsel1Coercion co = mkCoercion csel1CoercionTyCon [co] -mkCsel2Coercion co = mkCoercion csel2CoercionTyCon [co] -mkCselRCoercion co = mkCoercion cselRCoercionTyCon [co] - -------------------------------- -mkInstCoercion :: Coercion -> Type -> Coercion --- ^ Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs --- the resulting beta-reduction, otherwise it creates a suspended instantiation. -mkInstCoercion co ty = mkCoercion instCoercionTyCon [co, ty] - -mkInstsCoercion :: Coercion -> [Type] -> Coercion --- ^ As 'mkInstCoercion', but instantiates the coercion with a number of type arguments, left-to-right -mkInstsCoercion co tys = foldl mkInstCoercion co tys - --- | Manufacture a coercion from this air. Needless to say, this is not usually safe, --- but it is used when we know we are dealing with bottom, which is one case in which --- it is safe. This is also used implement the @unsafeCoerce#@ primitive. --- Optimise by pushing down through type constructors -mkUnsafeCoercion :: Type -> Type -> Coercion -mkUnsafeCoercion (TyConApp tc1 tys1) (TyConApp tc2 tys2) +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co@(Refl {}) = co +mkSymCo (UnsafeCo ty1 ty2) = UnsafeCo ty2 ty1 +mkSymCo (SymCo co) = co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo (Refl _) co = co +mkTransCo co (Refl _) = co +mkTransCo co1 co2 = TransCo co1 co2 + +mkNthCo :: Int -> Coercion -> Coercion +mkNthCo n (Refl ty) = Refl (getNth n ty) +mkNthCo n co = NthCo n co + +-- | Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs +-- the resulting beta-reduction, otherwise it creates a suspended instantiation. +mkInstCo :: Coercion -> Type -> Coercion +mkInstCo (ForAllCo tv co) ty = substCoWithTy tv ty co +mkInstCo co ty = InstCo co ty + +-- | Manufacture a coercion from thin air. Needless to say, this is +-- not usually safe, but it is used when we know we are dealing with +-- bottom, which is one case in which it is safe. This is also used +-- to implement the @unsafeCoerce#@ primitive. Optimise by pushing +-- down through type constructors. +mkUnsafeCo :: Type -> Type -> Coercion +mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1 +mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2 - = TyConApp tc1 (zipWith mkUnsafeCoercion tys1 tys2) + = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2) -mkUnsafeCoercion (FunTy a1 r1) (FunTy a2 r2) - = FunTy (mkUnsafeCoercion a1 a2) (mkUnsafeCoercion r1 r2) +mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2) + = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2) -mkUnsafeCoercion ty1 ty2 - | ty1 `coreEqType` ty2 = ty1 - | otherwise = mkCoercion unsafeCoercionTyCon [ty1, ty2] +mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2 -- See note [Newtype coercions] in TyCon --- | Create a coercion suitable for the given 'TyCon'. The 'Name' should be that of a --- new coercion 'TyCon', the 'TyVar's the arguments expected by the @newtype@ and the --- type the appropriate right hand side of the @newtype@, with the free variables --- a subset of those 'TyVar's. -mkNewTypeCoercion :: Name -> TyCon -> [TyVar] -> Type -> TyCon -mkNewTypeCoercion name tycon tvs rhs_ty - = mkCoercionTyCon name arity desc - where - arity = length tvs - desc = CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs) - , co_ax_rhs = rhs_ty } +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom +mkNewTypeCo name tycon tvs rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs) + , co_ax_rhs = rhs_ty } -- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type -- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is --- the coercion tycon built here, @F@ the family tycon and @R@ the (derived) +-- the coercion constructor built here, @F@ the family tycon and @R@ the (derived) -- representation tycon. -mkFamInstCoercion :: Name -- ^ Unique name for the coercion tycon +mkFamInstCo :: Name -- ^ Unique name for the coercion tycon -> [TyVar] -- ^ Type parameters of the coercion (@tvs@) -> TyCon -- ^ Family tycon (@F@) -> [Type] -- ^ Type instance (@ts@) -> TyCon -- ^ Representation tycon (@R@) - -> TyCon -- ^ Coercion tycon (@Co@) -mkFamInstCoercion name tvs family inst_tys rep_tycon - = mkCoercionTyCon name arity desc - where - arity = length tvs - desc = CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = mkTyConApp family inst_tys - , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) } - - -mkClassPPredCo :: Class -> [Coercion] -> Coercion -mkClassPPredCo cls = (PredTy . ClassP cls) - -mkIParamPredCo :: (IPName Name) -> Coercion -> Coercion -mkIParamPredCo ipn = (PredTy . IParam ipn) - -mkEqPredCo :: Coercion -> Coercion -> Coercion -mkEqPredCo co1 co2 = PredTy (EqPred co1 co2) - - -\end{code} - - -%************************************************************************ -%* * - Coercion Type Constructors -%* * -%************************************************************************ - -Example. The coercion ((sym c) (sym d) (sym e)) -will be represented by (TyConApp sym [c, sym d, sym e]) -If sym c :: p1=q1 - sym d :: p2=q2 - sym e :: p3=q3 -then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3) - -\begin{code} --- | Coercion type constructors: avoid using these directly and instead use --- the @mk*Coercion@ and @split*Coercion@ family of functions if possible. --- --- Each coercion TyCon is built with the special CoercionTyCon record and --- carries its own kinding rule. Such CoercionTyCons must be fully applied --- by any TyConApp in which they are applied, however they may also be over --- applied (see example above) and the kinding function must deal with this. -symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon, - csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon :: TyCon - -symCoercionTyCon = mkCoercionTyCon symCoercionTyConName 1 CoSym -transCoercionTyCon = mkCoercionTyCon transCoercionTyConName 2 CoTrans -leftCoercionTyCon = mkCoercionTyCon leftCoercionTyConName 1 CoLeft -rightCoercionTyCon = mkCoercionTyCon rightCoercionTyConName 1 CoRight -instCoercionTyCon = mkCoercionTyCon instCoercionTyConName 2 CoInst -csel1CoercionTyCon = mkCoercionTyCon csel1CoercionTyConName 1 CoCsel1 -csel2CoercionTyCon = mkCoercionTyCon csel2CoercionTyConName 1 CoCsel2 -cselRCoercionTyCon = mkCoercionTyCon cselRCoercionTyConName 1 CoCselR -unsafeCoercionTyCon = mkCoercionTyCon unsafeCoercionTyConName 2 CoUnsafe - -transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName, - rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName, - csel1CoercionTyConName, csel2CoercionTyConName, cselRCoercionTyConName :: Name - -transCoercionTyConName = mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon -symCoercionTyConName = mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon -leftCoercionTyConName = mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon -rightCoercionTyConName = mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon -instCoercionTyConName = mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon -csel1CoercionTyConName = mkCoConName (fsLit "csel1") csel1CoercionTyConKey csel1CoercionTyCon -csel2CoercionTyConName = mkCoConName (fsLit "csel2") csel2CoercionTyConKey csel2CoercionTyCon -cselRCoercionTyConName = mkCoConName (fsLit "cselR") cselRCoercionTyConKey cselRCoercionTyCon -unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon - -mkCoConName :: FastString -> Unique -> TyCon -> Name -mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkTcOccFS occ) - key (ATyCon coCon) BuiltInSyntax -\end{code} - -\begin{code} ------------- -decompLR_maybe :: (Type,Type) -> Maybe ((Type,Type), (Type,Type)) --- Helper for left and right. Finds coercion kind of its input and --- returns the left and right projections of the coercion... --- --- if c :: t1 s1 ~ t2 s2 then splitCoercionKindOf c = ((t1, t2), (s1, s2)) -decompLR_maybe (ty1,ty2) - | Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1 - , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2 - = Just ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2)) -decompLR_maybe _ = Nothing - ------------- -decompInst_maybe :: (Type, Type) -> Maybe ((TyVar,TyVar), (Type,Type)) -decompInst_maybe (ty1, ty2) - | Just (tv1,r1) <- splitForAllTy_maybe ty1 - , Just (tv2,r2) <- splitForAllTy_maybe ty2 - = Just ((tv1,tv2), (r1,r2)) -decompInst_maybe _ = Nothing - ------------- -decompCsel_maybe :: (Type, Type) -> Maybe ((Type,Type), (Type,Type), (Type,Type)) --- If co :: (s1~t1 => r1) ~ (s2~t2 => r2) --- Then csel1 co :: s1 ~ s2 --- csel2 co :: t1 ~ t2 --- cselR co :: r1 ~ r2 -decompCsel_maybe (ty1, ty2) - | Just (s1, t1, r1) <- splitCoPredTy_maybe ty1 - , Just (s2, t2, r2) <- splitCoPredTy_maybe ty2 - = Just ((s1,s2), (t1,t2), (r1,r2)) -decompCsel_maybe _ = Nothing + -> CoAxiom -- ^ Coercion constructor (@Co@) +mkFamInstCo name tvs family inst_tys rep_tycon + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp family inst_tys + , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) } + +mkPiCos :: [Var] -> Coercion -> Coercion +mkPiCos vs co = foldr mkPiCo co vs + +mkPiCo :: Var -> Coercion -> Coercion +mkPiCo v co | isTyVar v = mkForAllCo v co + | otherwise = mkFunCo (mkReflCo (varType v)) co \end{code} - %************************************************************************ %* * Newtypes @@ -561,17 +668,14 @@ decompCsel_maybe _ = Nothing %************************************************************************ \begin{code} -instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI) +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) -- ^ If @co :: T ts ~ rep_ty@ then: -- -- > instNewTyCon_maybe T ts = Just (rep_ty, co) instNewTyCon_maybe tc tys - | Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc + | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc = ASSERT( tys `lengthIs` tyConArity tc ) - Just (substTyWith tvs tys ty, - case mb_co_tc of - Nothing -> IdCo (mkTyConApp tc tys) - Just co_tc -> ACo (mkTyConApp co_tc tys)) + Just (substTyWith tvs tys ty, mkAxInstCo co_tc tys) | otherwise = Nothing @@ -588,270 +692,440 @@ splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion) splitNewTypeRepCo_maybe ty | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty' splitNewTypeRepCo_maybe (TyConApp tc tys) - | Just (ty', coi) <- instNewTyCon_maybe tc tys - = case coi of - ACo co -> Just (ty', co) - IdCo _ -> panic "splitNewTypeRepCo_maybe" + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case co of + Refl _ -> panic "splitNewTypeRepCo_maybe" -- This case handled by coreView + _ -> Just (ty', co) splitNewTypeRepCo_maybe _ = Nothing -- | Determines syntactic equality of coercions coreEqCoercion :: Coercion -> Coercion -> Bool -coreEqCoercion = coreEqType +coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2 + where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2)) coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool -coreEqCoercion2 = coreEqType2 -\end{code} +coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2 +coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2) + = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 + +coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22) + = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 + +coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2) + = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2 + +coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2) + = rnOccL env cv1 == rnOccR env cv2 + +coreEqCoercion2 env (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2) + = con1 == con2 + && all2 (coreEqCoercion2 env) cos1 cos2 + +coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22) + = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 +coreEqCoercion2 env (SymCo co1) (SymCo co2) + = coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) + = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 + +coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) + = d1 == d2 && coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) + = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 + +coreEqCoercion2 _ _ _ = False +\end{code} %************************************************************************ %* * - CoercionI and its constructors -%* * + Substitution of coercions +%* * %************************************************************************ --------------------------------------- --- CoercionI smart constructors --- lifted smart constructors of ordinary coercions +\begin{code} +-- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when +-- doing a \"lifting\" substitution) +type CvSubstEnv = VarEnv Coercion + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +data CvSubst + = CvSubst InScopeSet -- The in-scope type variables + TvSubstEnv -- Substitution of types + CvSubstEnv -- Substitution of coercions + +instance Outputable CvSubst where + ppr (CvSubst ins tenv cenv) + = brackets $ sep[ ptext (sLit "CvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv), + nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ] + +emptyCvSubst :: CvSubst +emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv + +isEmptyCvSubst :: CvSubst -> Bool +isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +getCvInScope :: CvSubst -> InScopeSet +getCvInScope (CvSubst in_scope _ _) = in_scope + +zapCvSubstEnv :: CvSubst -> CvSubst +zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv + +cvTvSubst :: CvSubst -> TvSubst +cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs + +tvCvSubst :: TvSubst -> CvSubst +tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv + +extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst +extendTvSubst (CvSubst in_scope tenv cenv) tv ty + = CvSubst in_scope (extendVarEnv tenv tv ty) cenv + +substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar) +substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) + -- In that case, mkCoVarCo will return a ReflCoercion, and + -- we want to substitute that (not new_var) for old_var + new_co = mkCoVarCo new_var + no_change = new_var == old_var && not (isReflCo new_co) + + 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) (substTy subst (varType old_var)) + -- It's important to do the substitution for coercions, + -- because only they can have free type variables + +substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) +substTyVarBndr (CvSubst in_scope tenv cenv) old_var + = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of + (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var) + +zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst +zipOpenCvSubst vs cos + | debugIsOn && (length vs /= length cos) + = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst + | otherwise + = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos) + +mkTopCvSubst :: [(Var,Coercion)] -> CvSubst +mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs) + +substCoWithTy :: TyVar -> Type -> Coercion -> Coercion +substCoWithTy tv ty = substCoWithTys [tv] [ty] + +substCoWithTys :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithTys tvs tys co + | debugIsOn && (length tvs /= length tys) + = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co + | otherwise + = ASSERT( length tvs == length tys ) + substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co + where + in_scope = mkInScopeSet (tyVarsOfTypes tys) + +-- | Substitute within a 'Coercion' +substCo :: CvSubst -> Coercion -> Coercion +substCo subst co | isEmptyCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +substCos :: CvSubst -> [Coercion] -> [Coercion] +substCos subst cos | isEmptyCvSubst subst = cos + | otherwise = map (substCo subst) cos + +substTy :: CvSubst -> Type -> Type +substTy subst = Type.substTy (cvTvSubst subst) + +subst_co :: CvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = Coercion.substTy subst + + go :: Coercion -> Coercion + go (Refl ty) = Refl $! go_ty ty + go (TyConAppCo tc cos) = let args = map go cos + in args `seqList` TyConAppCo tc args + + go (AppCo co1 co2) = mkAppCo (go co1) $! go co2 + go (ForAllCo tv co) = case substTyVarBndr subst tv of + (subst', tv') -> + ForAllCo tv' $! subst_co subst' co + + go (PredCo p) = mkPredCo (go <$> p) + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con cos) = AxiomInstCo con $! map go cos + go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2 + go (SymCo co) = mkSymCo (go co) + go (TransCo co1 co2) = mkTransCo (go co1) (go co2) + go (NthCo d co) = mkNthCo d (go co) + go (InstCo co ty) = mkInstCo (go co) $! go_ty ty + +substCoVar :: CvSubst -> CoVar -> Coercion +substCoVar (CvSubst in_scope _ cenv) cv + | Just co <- lookupVarEnv cenv cv = co + | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 + | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv ) + ASSERT( isCoVar cv ) CoVarCo cv + +substCoVars :: CvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupTyVar :: CvSubst -> TyVar -> Maybe Type +lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv + +lookupCoVar :: CvSubst -> Var -> Maybe Coercion +lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v +\end{code} + +%************************************************************************ +%* * + "Lifting" substitution + [(TyVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ \begin{code} --- | 'CoercionI' represents a /lifted/ ordinary 'Coercion', in that it --- can represent either one of: --- --- 1. A proper 'Coercion' +liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith tvs cos = liftCoSubst (zipOpenCvSubst tvs cos) + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. -- --- 2. The identity coercion -data CoercionI = IdCo Type | ACo Coercion +-- For the inverse operation, see 'liftCoMatch' +liftCoSubst :: CvSubst -> Type -> Coercion +-- The CvSubst maps TyVar -> Type (mainly for cloning foralls) +-- TyVar -> Coercion (this is the payload) +-- The unusual thing is that the *coercion* substitution maps +-- some *type* variables. That's the whole point of this function! +liftCoSubst subst ty | isEmptyCvSubst subst = Refl ty + | otherwise = ty_co_subst subst ty + +ty_co_subst :: CvSubst -> Type -> Coercion +ty_co_subst subst ty + = go ty + where + go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv) + go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2) + go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) + go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2) + go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) + where + (subst', v') = liftCoSubstTyVarBndr subst v + go (PredTy p) = mkPredCo (go <$> p) + +liftCoSubstTyVar :: CvSubst -> TyVar -> Maybe Coercion +liftCoSubstTyVar subst@(CvSubst _ tenv cenv) tv + = case (lookupVarEnv tenv tv, lookupVarEnv cenv tv) of + (Nothing, Nothing) -> Nothing + (Just ty, Nothing) -> Just (Refl ty) + (Nothing, Just co) -> Just co + (Just {}, Just {}) -> pprPanic "ty_co_subst" (ppr tv $$ ppr subst) + +liftCoSubstTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) +liftCoSubstTyVarBndr (CvSubst in_scope tenv cenv) old_var + = (CvSubst (in_scope `extendInScopeSet` new_var) + new_tenv + (delVarEnv cenv old_var) -- See Note [Lifting substitutions] + , new_var) + where + new_tenv | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_change = new_var == old_var + new_var = uniqAway in_scope old_var +\end{code} + +Note [Lifting substitutions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider liftCoSubstWith [a] [co] (a, forall a. a) +Then we want to substitute for the free 'a', but obviously not for +the bound 'a'. hence the (delVarEnv cent old_var) in liftCoSubstTyVarBndr. -liftCoI :: (Type -> Type) -> CoercionI -> CoercionI -liftCoI f (IdCo ty) = IdCo (f ty) -liftCoI f (ACo ty) = ACo (f ty) +This also why we need a full CvSubst when doing lifting substitutions. -liftCoI2 :: (Type -> Type -> Type) -> CoercionI -> CoercionI -> CoercionI -liftCoI2 f (IdCo ty1) (IdCo ty2) = IdCo (f ty1 ty2) -liftCoI2 f coi1 coi2 = ACo (f (fromCoI coi1) (fromCoI coi2)) +\begin{code} +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe CvSubst +liftCoMatch tmpls ty co + = case ty_co_match menv (emptyVarEnv, emptyVarEnv) ty co of + Just (tv_env, cv_env) -> Just (CvSubst in_scope tv_env cv_env) + Nothing -> Nothing + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + +type TyCoSubstEnv = (TvSubstEnv, CvSubstEnv) + -- Used locally inside ty_co_match only + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -> TyCoSubstEnv -> Type -> Coercion -> Maybe TyCoSubstEnv +ty_co_match menv subst ty co | Just ty' <- coreView ty = ty_co_match menv subst ty' co + + -- Deal with the Refl case by delegating to type matching +ty_co_match menv (tenv, cenv) ty co + | Just ty' <- isReflCo_maybe co + = case ruleMatchTyX ty_menv tenv ty ty' of + Just tenv' -> Just (tenv', cenv) + Nothing -> Nothing + where + ty_menv = menv { me_tmpls = me_tmpls menv `minusUFM` cenv } + -- Remove from the template set any variables already bound to non-refl coercions + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst@(tenv, cenv) (TyVarTy tv1) co + | Just {} <- lookupVarEnv tenv tv1' -- tv1' is already bound to (Refl ty) + = Nothing -- The coercion 'co' is not Refl + + | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1 + = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co)) + then Nothing -- occurs check failed + else return (tenv, extendVarEnv cenv tv1' co) + -- BAY: I don't think we need to do any kind matching here yet + -- (compare 'match'), but we probably will when moving to SHE. + + | otherwise -- tv1 is not a template ty var, so the only thing it + -- can match is a reflexivity coercion for itself. + -- But that case is dealt with already + = Nothing -liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI -liftCoIs f cois = go_id [] cois where - go_id rev_tys [] = IdCo (f (reverse rev_tys)) - go_id rev_tys (IdCo ty : cois) = go_id (ty:rev_tys) cois - go_id rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois - - go_aco rev_tys [] = ACo (f (reverse rev_tys)) - go_aco rev_tys (IdCo ty : cois) = go_aco (ty:rev_tys) cois - go_aco rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois - -instance Outputable CoercionI where - ppr (IdCo _) = ptext (sLit "IdCo") - ppr (ACo co) = ppr co - -isIdentityCoI :: CoercionI -> Bool -isIdentityCoI (IdCo _) = True -isIdentityCoI (ACo _) = False - --- | Return either the 'Coercion' contained within the 'CoercionI' or the given --- 'Type' if the 'CoercionI' is the identity 'Coercion' -fromCoI :: CoercionI -> Type -fromCoI (IdCo ty) = ty -- Identity coercion represented -fromCoI (ACo co) = co -- by the type itself - --- | Smart constructor for @sym@ on 'CoercionI', see also 'mkSymCoercion' -mkSymCoI :: CoercionI -> CoercionI -mkSymCoI (IdCo ty) = IdCo ty -mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co] - -- the smart constructor - -- is too smart with tyvars - --- | Smart constructor for @trans@ on 'CoercionI', see also 'mkTransCoercion' -mkTransCoI :: CoercionI -> CoercionI -> CoercionI -mkTransCoI (IdCo _) aco = aco -mkTransCoI aco (IdCo _) = aco -mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2 - --- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion' -mkTyConAppCoI :: TyCon -> [CoercionI] -> CoercionI -mkTyConAppCoI tyCon cois = liftCoIs (mkTyConApp tyCon) cois - --- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion' -mkAppTyCoI :: CoercionI -> CoercionI -> CoercionI -mkAppTyCoI = liftCoI2 mkAppTy - -mkFunTyCoI :: CoercionI -> CoercionI -> CoercionI -mkFunTyCoI = liftCoI2 mkFunTy - --- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion' -mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI -mkForAllTyCoI tv = liftCoI (ForAllTy tv) - --- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies: --- --- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois)) -mkClassPPredCoI :: Class -> [CoercionI] -> CoercionI -mkClassPPredCoI cls = liftCoIs (PredTy . ClassP cls) + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + +ty_co_match menv subst (AppTy ty1 ty2) (AppCo co1 co2) -- BAY: do we need to work harder to decompose the AppCo? + = do { subst' <- ty_co_match menv subst ty1 co1 + ; ty_co_match menv subst' ty2 co2 } --- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI' -mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI -mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn) +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos) + | tc1 == tc2 = ty_co_matches menv subst tys cos --- | Smart constructor for type equality 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI' -mkEqPredCoI :: CoercionI -> CoercionI -> CoercionI -mkEqPredCoI = liftCoI2 (\t1 t2 -> PredTy (EqPred t1 t2)) +ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos) + | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos -mkCoPredCoI :: CoercionI -> CoercionI -> CoercionI -> CoercionI -mkCoPredCoI coi1 coi2 coi3 = mkFunTyCoI (mkEqPredCoI coi1 coi2) coi3 +ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) + = ty_co_match menv' subst ty co + where + menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } +ty_co_match _ _ _ _ = Nothing +ty_co_matches :: MatchEnv -> TyCoSubstEnv -> [Type] -> [Coercion] -> Maybe TyCoSubstEnv +ty_co_matches menv = matchList (ty_co_match menv) \end{code} %************************************************************************ %* * - The kind of a type, and of a coercion + Sequencing on coercions %* * %************************************************************************ \begin{code} -typeKind :: Type -> Kind -typeKind ty@(TyConApp tc tys) - | isCoercionTyCon tc = typeKind (fst (coercionKind ty)) - | otherwise = kindAppResult (tyConKind tc) tys - -- During coercion optimisation we *do* match a type - -- against a coercion (see OptCoercion.matchesAxiomLhs) - -- So the use of typeKind in Unify.match_kind must work on coercions too - -- Hence the isCoercionTyCon case above - -typeKind (PredTy pred) = predKind pred -typeKind (AppTy fun _) = kindFunResult (typeKind fun) -typeKind (ForAllTy _ ty) = typeKind ty -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy _arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypKind (#) - -- The only things that can be after a function arrow are - -- (a) types (of kind openTypeKind or its sub-kinds) - -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isTySuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind - where - k = typeKind res +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv co) = tv `seq` seqCo co +seqCo (PredCo p) = seqPred seqCo p +seqCo (CoVarCo cv) = cv `seq` () +seqCo (AxiomInstCo con cos) = con `seq` seqCos cos +seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo _ co) = seqCo co +seqCo (InstCo co ty) = seqCo co `seq` seqType ty + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos +\end{code} ------------------- -predKind :: PredType -> Kind -predKind (EqPred {}) = coSuperKind -- A coercion kind! -predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are -predKind (IParam {}) = liftedTypeKind -- always represented by lifted types + +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ + +\begin{code} +coercionType :: Coercion -> Type +coercionType co = case coercionKind co of + Pair ty1 ty2 -> mkCoType ty1 ty2 ------------------ -- | If it is the case that -- -- > c :: (t1 ~ t2) -- --- i.e. the kind of @c@ is a 'CoercionKind' relating @t1@ and @t2@, --- then @coercionKind c = (t1, t2)@. -coercionKind :: Coercion -> (Type, Type) -coercionKind ty@(TyVarTy a) | isCoVar a = coVarKind a - | otherwise = (ty, ty) -coercionKind (AppTy ty1 ty2) - = let (s1, t1) = coercionKind ty1 - (s2, t2) = coercionKind ty2 in - (mkAppTy s1 s2, mkAppTy t1 t2) -coercionKind co@(TyConApp tc args) - | Just (ar, desc) <- isCoercionTyCon_maybe tc - -- CoercionTyCons carry their kinding rule, so we use it here - = WARN( not (length args >= ar), ppr co ) -- Always saturated - (let (ty1, ty2) = coTyConAppKind desc (take ar args) - (tys1, tys2) = coercionKinds (drop ar args) - in (mkAppTys ty1 tys1, mkAppTys ty2 tys2)) - - | otherwise - = let (lArgs, rArgs) = coercionKinds args in - (TyConApp tc lArgs, TyConApp tc rArgs) - -coercionKind (FunTy ty1 ty2) - = let (t1, t2) = coercionKind ty1 - (s1, s2) = coercionKind ty2 in - (mkFunTy t1 s1, mkFunTy t2 s2) - -coercionKind (ForAllTy tv ty) - | isCoVar tv +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. +coercionKind :: Coercion -> Pair Type +coercionKind (Refl ty) = Pair ty ty +coercionKind (TyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map coercionKind cos) +coercionKind (AppCo co1 co2) = mkAppTy <$> coercionKind co1 <*> coercionKind co2 +coercionKind (ForAllCo tv co) = mkForAllTy tv <$> coercionKind co + -- BAY*: is the above still correct for equality + -- abstractions? the System FC paper seems to imply we can + -- only ever construct coercions between foralls whose + -- variables have *equal* kinds. But there was this comment + -- below suggesting otherwise: + -- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2 -- ---------------------------------------------- -- c1~c2 => c3 :: (s1~t1) => r1 ~ (s2~t2) => r2 -- or -- forall (_:c1~c2) - = let (c1,c2) = coVarKind tv - (s1,s2) = coercionKind c1 - (t1,t2) = coercionKind c2 - (r1,r2) = coercionKind ty - in - (mkCoPredTy s1 t1 r1, mkCoPredTy s2 t2 r2) - - | otherwise --- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2 --- ---------------------------------------------- --- forall a:k. c :: forall a:k. t1 ~ forall a:k. t2 - = let (ty1, ty2) = coercionKind ty in - (ForAllTy tv ty1, ForAllTy tv ty2) - -coercionKind (PredTy (ClassP cl args)) - = let (lArgs, rArgs) = coercionKinds args in - (PredTy (ClassP cl lArgs), PredTy (ClassP cl rArgs)) -coercionKind (PredTy (IParam name ty)) - = let (ty1, ty2) = coercionKind ty in - (PredTy (IParam name ty1), PredTy (IParam name ty2)) -coercionKind (PredTy (EqPred c1 c2)) - = pprTrace "coercionKind" (pprEqPred (c1,c2)) $ - -- These should not show up in coercions at all - -- becuase they are in the form of for-alls - let k1 = coercionKindPredTy c1 - k2 = coercionKindPredTy c2 in - (k1,k2) - where - coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2 +coercionKind (CoVarCo cv) = ASSERT( isCoVar cv ) toPair $ coVarKind cv +coercionKind (AxiomInstCo ax cos) = let Pair tys1 tys2 = coercionKinds cos + in Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax)) + (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax)) +coercionKind (UnsafeCo ty1 ty2) = Pair ty1 ty2 +coercionKind (SymCo co) = swap $ coercionKind co +coercionKind (TransCo co1 co2) = Pair (pFst $ coercionKind co1) (pSnd $ coercionKind co2) +coercionKind (NthCo d co) = getNth d <$> coercionKind co +coercionKind (InstCo co ty) | Just ks <- splitForAllTy_maybe `traverse` coercionKind co + = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks + -- fall-through error case. +coercionKind co = pprPanic "coercionKind" (ppr co) ------------------- -- | Apply 'coercionKind' to multiple 'Coercion's -coercionKinds :: [Coercion] -> ([Type], [Type]) -coercionKinds tys = unzip $ map coercionKind tys +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys ------------------- --- | 'coTyConAppKind' is given a list of the type arguments to the 'CoTyCon', --- and constructs the types that the resulting coercion relates. --- Fails (in the monad) if ill-kinded. --- Typically the monad is --- either the Lint monad (with the consistency-check flag = True), --- or the ID monad with a panic on failure (and the consistency-check flag = False) -coTyConAppKind - :: CoTyConDesc - -> [Type] -- Exactly right number of args - -> (Type, Type) -- Kind of this application -coTyConAppKind CoUnsafe (ty1:ty2:_) - = (ty1,ty2) -coTyConAppKind CoSym (co:_) - | (ty1,ty2) <- coercionKind co = (ty2,ty1) -coTyConAppKind CoTrans (co1:co2:_) - = (fst (coercionKind co1), snd (coercionKind co2)) -coTyConAppKind CoLeft (co:_) - | Just (res,_) <- decompLR_maybe (coercionKind co) = res -coTyConAppKind CoRight (co:_) - | Just (_,res) <- decompLR_maybe (coercionKind co) = res -coTyConAppKind CoCsel1 (co:_) - | Just (res,_,_) <- decompCsel_maybe (coercionKind co) = res -coTyConAppKind CoCsel2 (co:_) - | Just (_,res,_) <- decompCsel_maybe (coercionKind co) = res -coTyConAppKind CoCselR (co:_) - | Just (_,_,res) <- decompCsel_maybe (coercionKind co) = res -coTyConAppKind CoInst (co:ty:_) - | Just ((tv1,tv2), (ty1,ty2)) <- decompInst_maybe (coercionKind co) - = (substTyWith [tv1] [ty] ty1, substTyWith [tv2] [ty] ty2) -coTyConAppKind (CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos - = (substTyWith tvs tys1 lhs_ty, substTyWith tvs tys2 rhs_ty) - where - (tys1, tys2) = coercionKinds cos -coTyConAppKind desc cos = pprTrace "coTyConAppKind" (ppr desc $$ braces (vcat - [ ppr co <+> dcolon <+> pprEqPred (coercionKind co) - | co <- cos ])) $ - coercionKind (head cos) +getNth :: Int -> Type -> Type +getNth n ty | Just (_, tys) <- splitTyConApp_maybe ty + = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n +getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty) \end{code} + +\begin{code} +applyCo :: Type -> Coercion -> Type +-- Gives the type of (e co) where e :: (a~b) => ty +applyCo ty co | Just ty' <- coreView ty = applyCo ty' co +applyCo (FunTy _ ty) _ = ty +applyCo _ _ = panic "applyCo" +\end{code}
\ No newline at end of file diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 93a67a7edd..894da340c7 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -29,7 +29,6 @@ import TypeRep import TyCon import Coercion import VarSet -import Var import Name import UniqFM import Outputable @@ -303,7 +302,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs -- anything else would be difficult to test for at this stage. conflicting old_fam_inst subst | isAlgTyCon fam = True - | otherwise = not (old_rhs `tcEqType` new_rhs) + | otherwise = not (old_rhs `eqType` new_rhs) where old_tycon = famInstTyCon old_fam_inst old_tvs = tyConTyVars old_tycon @@ -439,35 +438,34 @@ topNormaliseType env ty go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms = go rec_nts ty' - go rec_nts (TyConApp tc tys) -- Expand newtypes - | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes] - = if tc `elem` rec_nts -- in Type.lhs + go rec_nts (TyConApp tc tys) + | isNewTyCon tc -- Expand newtypes + = if tc `elem` rec_nts -- See Note [Expanding newtypes] in Type.lhs then Nothing - else let nt_co = mkTyConApp co_con tys - in add_co nt_co rec_nts' nt_rhs - where - nt_rhs = newTyConInstRhs tc tys - rec_nts' | isRecursiveTyCon tc = tc:rec_nts - | otherwise = rec_nts - - go rec_nts (TyConApp tc tys) -- Expand open tycons - | isFamilyTyCon tc - , (ACo co, ty) <- normaliseTcApp env tc tys - = -- The ACo says "something happened" - -- Note that normaliseType fully normalises, but it has do to so - -- to be sure that - add_co co rec_nts ty + else let nt_co = mkAxInstCo (newTyConCo tc) tys + in add_co nt_co rec_nts' nt_rhs + + | isFamilyTyCon tc -- Expand open tycons + , (co, ty) <- normaliseTcApp env tc tys + -- Note that normaliseType fully normalises, + -- but it has do to so to be sure that + , not (isReflCo co) + = add_co co rec_nts ty + where + nt_rhs = newTyConInstRhs tc tys + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts go _ _ = Nothing add_co co rec_nts ty = case go rec_nts ty of Nothing -> Just (co, ty) - Just (co', ty') -> Just (mkTransCoercion co co', ty') + Just (co', ty') -> Just (mkTransCo co co', ty') --------------- -normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type) +normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type) normaliseTcApp env tc tys | isFamilyTyCon tc , tyConArity tc <= length tys -- Unsaturated data families are possible @@ -475,29 +473,30 @@ normaliseTcApp env tc tys = let -- A matching family instance exists rep_tc = famInstTyCon fam_inst co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc) - co = mkTyConApp co_tycon inst_tys - first_coi = mkTransCoI tycon_coi (ACo co) - (rest_coi, nty) = normaliseType env (mkTyConApp rep_tc inst_tys) - fix_coi = mkTransCoI first_coi rest_coi + co = mkAxInstCo co_tycon inst_tys + first_coi = mkTransCo tycon_coi co + (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc inst_tys) + fix_coi = mkTransCo first_coi rest_coi in (fix_coi, nty) - | otherwise + | otherwise -- No unique matching family instance exists; + -- we do not do anything = (tycon_coi, TyConApp tc ntys) where -- Normalise the arg types so that they'll match -- when we lookup in in the instance envt (cois, ntys) = mapAndUnzip (normaliseType env) tys - tycon_coi = mkTyConAppCoI tc cois + tycon_coi = mkTyConAppCo tc cois --------------- normaliseType :: FamInstEnvs -- environment with family instances -> Type -- old type - -> (CoercionI, Type) -- (coercion,new type), where + -> (Coercion, Type) -- (coercion,new type), where -- co :: old-type ~ new_type -- Normalise the input type, by eliminating *all* type-function redexes --- Returns with IdCo if nothing happens +-- Returns with Refl if nothing happens normaliseType env ty | Just ty' <- coreView ty = normaliseType env ty' @@ -506,29 +505,29 @@ normaliseType env (TyConApp tc tys) normaliseType env (AppTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 - in (mkAppTyCoI coi1 coi2, mkAppTy nty1 nty2) + in (mkAppCo coi1 coi2, mkAppTy nty1 nty2) normaliseType env (FunTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 - in (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2) + in (mkFunCo coi1 coi2, mkFunTy nty1 nty2) normaliseType env (ForAllTy tyvar ty1) = let (coi,nty1) = normaliseType env ty1 - in (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1) + in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) normaliseType _ ty@(TyVarTy _) - = (IdCo ty,ty) + = (Refl ty,ty) normaliseType env (PredTy predty) = normalisePred env predty --------------- -normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type) +normalisePred :: FamInstEnvs -> PredType -> (Coercion,Type) normalisePred env (ClassP cls tys) - = let (cois,tys') = mapAndUnzip (normaliseType env) tys - in (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys') + = let (cos,tys') = mapAndUnzip (normaliseType env) tys + in (mkPredCo $ ClassP cls cos, PredTy $ ClassP cls tys') normalisePred env (IParam ipn ty) - = let (coi,ty') = normaliseType env ty - in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty') + = let (co,ty') = normaliseType env ty + in (mkPredCo $ (IParam ipn co), PredTy $ IParam ipn ty') normalisePred env (EqPred ty1 ty2) - = let (coi1,ty1') = normaliseType env ty1 - (coi2,ty2') = normaliseType env ty2 - in (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2') + = let (co1,ty1') = normaliseType env ty1 + (co2,ty2') = normaliseType env ty2 + in (mkPredCo $ (EqPred co1 co2), PredTy $ EqPred ty1' ty2') \end{code} diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index 6ce932bfe3..9fa63044d4 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -271,8 +271,8 @@ improveFromAnother pred1@(ClassP cls1 tys1, _) pred2@(ClassP cls2 tys2, _) , fd <- cls_fds , let (ltys1, rs1) = instFD fd cls_tvs tys1 (ltys2, irs2) = instFD_WithPos fd cls_tvs tys2 - , tcEqTypes ltys1 ltys2 -- The LHSs match - , let eqs = zipAndComputeFDEqs tcEqType rs1 irs2 + , eqTypes ltys1 ltys2 -- The LHSs match + , let eqs = zipAndComputeFDEqs eqType rs1 irs2 , not (null eqs) ] improveFromAnother _ _ = [] diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 07f68f7b91..7a2a65e06b 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -119,7 +119,7 @@ instanceDFunId = is_dfun setInstanceDFunId :: Instance -> DFunId -> Instance setInstanceDFunId ispec dfun - = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) ) + = ASSERT( idType dfun `eqType` idType (is_dfun ispec) ) -- We need to create the cached fields afresh from -- the new dfun id. In particular, the is_tvs in -- the Instance must match those in the dfun! @@ -156,7 +156,7 @@ pprInstanceHdr ispec@(Instance { is_flag = flag }) | debugStyle sty = theta | otherwise = drop (dfunNSilent dfun) theta in ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrow theta_to_print, ppr res_ty] + <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty] where dfun = is_dfun ispec (_, theta, res_ty) = tcSplitSigmaTy (idType dfun) diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs new file mode 100644 index 0000000000..23787d20e2 --- /dev/null +++ b/compiler/types/Kind.lhs @@ -0,0 +1,232 @@ +% +% (c) The University of Glasgow 2006 +% + +\begin{code} +module Kind ( + -- * Main data type + Kind, typeKind, + + -- Kinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + mkArrowKind, mkArrowKinds, + + -- Kind constructors... + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + -- Super Kinds + tySuperKind, tySuperKindTyCon, + + pprKind, pprParendKind, + + -- ** Deconstructing Kinds + kindFunResult, kindAppResult, synTyConResKind, + splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, + + -- ** Predicates on Kinds + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, + isSuperKind, isCoercionKind, + isLiftedTypeKindCon, + + isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, + isSubKindCon, + + ) where + +#include "HsVersions.h" + +import TypeRep +import TysPrim +import TyCon +import Var +import PrelNames +import Outputable +\end{code} + +%************************************************************************ +%* * + Predicates over Kinds +%* * +%************************************************************************ + +\begin{code} +isTySuperKind :: SuperKind -> Bool +isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey +isTySuperKind _ = False + +------------------- +-- Lastly we need a few functions on Kinds + +isLiftedTypeKindCon :: TyCon -> Bool +isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey +\end{code} + +%************************************************************************ +%* * + The kind of a type +%* * +%************************************************************************ + +\begin{code} +typeKind :: Type -> Kind +typeKind (TyConApp tc tys) + = kindAppResult (tyConKind tc) tys + +typeKind (PredTy pred) = predKind pred +typeKind (AppTy fun _) = kindFunResult (typeKind fun) +typeKind (ForAllTy _ ty) = typeKind ty +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (FunTy _arg res) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypKind (#) + -- The only things that can be after a function arrow are + -- (a) types (of kind openTypeKind or its sub-kinds) + -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) + | isTySuperKind k = k + | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind + where + k = typeKind res + +------------------ +predKind :: PredType -> Kind +predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted +predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are +predKind (IParam {}) = liftedTypeKind -- always represented by lifted types +\end{code} + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ + +\begin{code} +-- | Essentially 'funResultTy' on kinds +kindFunResult :: Kind -> Kind +kindFunResult (FunTy _ res) = res +kindFunResult k = pprPanic "kindFunResult" (ppr k) + +kindAppResult :: Kind -> [arg] -> Kind +kindAppResult k [] = k +kindAppResult k (_:as) = kindAppResult (kindFunResult k) as + +-- | Essentially 'splitFunTys' on kinds +splitKindFunTys :: Kind -> ([Kind],Kind) +splitKindFunTys (FunTy a r) = case splitKindFunTys r of + (as, k) -> (a:as, k) +splitKindFunTys k = ([], k) + +splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) +splitKindFunTy_maybe (FunTy a r) = Just (a,r) +splitKindFunTy_maybe _ = Nothing + +-- | Essentially 'splitFunTysN' on kinds +splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) +splitKindFunTysN 0 k = ([], k) +splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of + (as, k) -> (a:as, k) +splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) + +-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's +isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool +isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, + isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool + +isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey + +isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc +isOpenTypeKind _ = False + +isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey + +isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc +isUbxTupleKind _ = False + +isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey + +isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc +isArgTypeKind _ = False + +isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey + +isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc +isUnliftedTypeKind _ = False + +isSubOpenTypeKind :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) +isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) + ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) + False +isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True +isSubOpenTypeKind other = ASSERT( isKind other ) False + -- This is a conservative answer + -- It matters in the call to isSubKind in + -- checkExpectedKind. + +isSubArgTypeKindCon kc + | isUnliftedTypeKindCon kc = True + | isLiftedTypeKindCon kc = True + | isArgTypeKindCon kc = True + | otherwise = False + +isSubArgTypeKind :: Kind -> Bool +-- ^ True of any sub-kind of ArgTypeKind +isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc +isSubArgTypeKind _ = False + +-- | Is this a super-kind (i.e. a type-of-kinds)? +isSuperKind :: Type -> Bool +isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc +isSuperKind _ = False + +-- | Is this a kind (i.e. a type-of-types)? +isKind :: Kind -> Bool +isKind k = isSuperKind (typeKind k) + +isSubKind :: Kind -> Kind -> Bool +-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ +isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 +isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) +isSubKind _ _ = False + +isSubKindCon :: TyCon -> TyCon -> Bool +-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ +isSubKindCon kc1 kc2 + | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True + | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True + | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True + | isOpenTypeKindCon kc2 = True + -- we already know kc1 is not a fun, its a TyCon + | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True + | otherwise = False + +defaultKind :: Kind -> Kind +-- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more +-- information on what that means + +-- When we generalise, we make generic type variables whose kind is +-- simple (* or *->* etc). So generic type variables (other than +-- built-in constants like 'error') always have simple kinds. This is important; +-- consider +-- f x = True +-- We want f to get type +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::??). a -> Bool +-- because that would allow a call like (f 3#) as well as (f True), +--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. +defaultKind k + | isSubOpenTypeKind k = liftedTypeKind + | isSubArgTypeKind k = liftedTypeKind + | otherwise = k +\end{code}
\ No newline at end of file diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index 26f3295b28..c95571245b 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -12,7 +12,7 @@ module OptCoercion ( import Unify ( tcMatchTy )
import Coercion
-import Type
+import Type hiding( substTyVarBndr, substTy, extendTvSubst )
import TypeRep
import TyCon
import Var
@@ -22,6 +22,10 @@ import PrelNames import StaticFlags ( opt_NoOptCoercion )
import Util
import Outputable
+import Unify
+import Pair
+import Maybes( allMaybes )
+import FastString
\end{code}
%************************************************************************
@@ -48,11 +52,11 @@ subsequent substitutions will go wrong. That's why we can't use mkCoPredTy in the ForAll case, where this note appears.
\begin{code}
-optCoercion :: TvSubst -> Coercion -> NormalCo
+optCoercion :: CvSubst -> Coercion -> NormalCo
-- ^ optCoercion applies a substitution to a coercion,
-- *and* optimises it to reduce its size
optCoercion env co
- | opt_NoOptCoercion = substTy env co
+ | opt_NoOptCoercion = substCo env co
| otherwise = opt_co env False co
type NormalCo = Coercion
@@ -64,201 +68,185 @@ type NormalCo = Coercion type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
-opt_co, opt_co' :: TvSubst
+opt_co, opt_co' :: CvSubst
-> Bool -- True <=> return (sym co)
-> Coercion
-> NormalCo
opt_co = opt_co'
-
-{- Debuggery
-opt_co env sym co
--- = pprTrace "opt_co {" (ppr sym <+> ppr co) $
--- co1 `seq`
--- pprTrace "opt_co done }" (ppr co1)
--- WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (s1,t1)
--- $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) )
- = WARN( not (coreEqType co1 simple_result),
+{-
+opt_co env sym co
+ = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
+ co1 `seq`
+ pprTrace "opt_co done }" (ppr co1) $
+ (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
+ $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
+ WARN( not (coreEqCoercion co1 simple_result),
(text "env=" <+> ppr env) $$
(text "input=" <+> ppr co) $$
(text "simple=" <+> ppr simple_result) $$
(text "opt=" <+> ppr co1) )
- co1
+ co1)
where
co1 = opt_co' env sym co
- same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2
- (s,t) = coercionKind (substTy env co)
+ same_co_kind = s1 `eqType` s2 && t1 `eqType` t2
+ Pair s t = coercionKind (substCo env co)
(s1,t1) | sym = (t,s)
| otherwise = (s,t)
- (s2,t2) = coercionKind co1
+ Pair s2 t2 = coercionKind co1
- simple_result | sym = mkSymCoercion (substTy env co)
- | otherwise = substTy env co
+ simple_result | sym = mkSymCo (substCo env co)
+ | otherwise = substCo env co
-}
-opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2)
-opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2)
-opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys))
-opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty))
-opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co)
-
-opt_co' env sym co@(TyVarTy tv)
- | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty
- | not (isCoVar tv) = co -- Identity; does not mention a CoVar
- | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto..
- | not sym = co
- | otherwise = mkSymCoercion co
+opt_co' env _ (Refl ty) = Refl (substTy env ty)
+opt_co' env sym (SymCo co) = opt_co env (not sym) co
+opt_co' env sym (TyConAppCo tc cos) = TyConAppCo tc (map (opt_co env sym) cos)
+opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2)
+opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of
+ (env', tv') -> ForAllCo tv' (opt_co env' sym co)
+opt_co' env sym (CoVarCo cv)
+ | Just co <- lookupCoVar env cv
+ = opt_co (zapCvSubstEnv env) sym co
+
+ | Just cv1 <- lookupInScope (getCvInScope env) cv
+ = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1)
+ -- cv1 might have a substituted kind!
+
+ | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
+ ASSERT( isCoVar cv )
+ wrapSym sym (CoVarCo cv)
+
+opt_co' env sym (AxiomInstCo con cos)
+ -- Do *not* push sym inside top-level axioms
+ -- e.g. if g is a top-level axiom
+ -- g a : f a ~ a
+ -- then (sym (g ty)) /= g (sym ty) !!
+ = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos)
+ -- Note that the_co does *not* have sym pushed into it
+
+opt_co' env sym (UnsafeCo ty1 ty2)
+ | ty1' `eqType` ty2' = Refl ty1'
+ | sym = mkUnsafeCo ty2' ty1'
+ | otherwise = mkUnsafeCo ty1' ty2'
where
- (ty1,ty2) = coVarKind tv
-
-opt_co' env sym (ForAllTy tv cor)
- | isTyVar tv = case substTyVarBndr env tv of
- (env', tv') -> ForAllTy tv' (opt_co' env' sym cor)
+ ty1' = substTy env ty1
+ ty2' = substTy env ty2
-opt_co' env sym co@(ForAllTy co_var cor)
- | isCoVar co_var
- = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co )
- ForAllTy co_var' cor'
+opt_co' env sym (TransCo co1 co2)
+ | sym = opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g
+ | otherwise = opt_trans opt_co1 opt_co2
where
- (co1,co2) = coVarKind co_var
- co1' = opt_co' env sym co1
- co2' = opt_co' env sym co2
- cor' = opt_co' env sym cor
- co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2'))
- -- See Note [Subtle shadowing in coercions]
-
-opt_co' env sym (TyConApp tc cos)
- | Just (arity, desc) <- isCoercionTyCon_maybe tc
- = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos))
- (map (opt_co env sym) (drop arity cos))
- | otherwise
- = TyConApp tc (map (opt_co env sym) cos)
-
---------
-opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo
--- Used for CoercionTyCons only
--- Arguments are *not* already simplified/substituted
-opt_co_tc_app env sym tc desc cos
- = case desc of
- CoAxiom {} -- Do *not* push sym inside top-level axioms
- -- e.g. if g is a top-level axiom
- -- g a : F a ~ a
- -- Then (sym (g ty)) /= g (sym ty) !!
- | sym -> mkSymCoercion the_co
- | otherwise -> the_co
- where
- the_co = TyConApp tc (map (opt_co env False) cos)
- -- Note that the_co does *not* have sym pushed into it
-
- CoTrans
- | sym -> opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g
- | otherwise -> opt_trans opt_co1 opt_co2
-
- CoUnsafe
- | sym -> mkUnsafeCoercion ty2' ty1'
- | otherwise -> mkUnsafeCoercion ty1' ty2'
-
- CoSym -> opt_co env (not sym) co1
- CoLeft -> opt_lr fst
- CoRight -> opt_lr snd
- CoCsel1 -> opt_csel fstOf3
- CoCsel2 -> opt_csel sndOf3
- CoCselR -> opt_csel thirdOf3
-
- CoInst -- See if the first arg is already a forall
- -- ...then we can just extend the current substitution
- | Just (tv, co1_body) <- splitForAllTy_maybe co1
- -> opt_co (extendTvSubst env tv ty2') sym co1_body
-
- -- See if is *now* a forall
- | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1
- -> substTyWith [tv] [ty2'] opt_co1_body -- An inefficient one-variable substitution
-
- | otherwise
- -> TyConApp tc [opt_co1, ty2']
+ opt_co1 = opt_co env sym co1
+ opt_co2 = opt_co env sym co2
+opt_co' env sym (NthCo n co)
+ | TyConAppCo tc cos <- co'
+ , isDecomposableTyCon tc -- Not synonym families
+ = ASSERT( n < length cos )
+ cos !! n
+ | otherwise
+ = NthCo n co'
where
- (co1 : cos1) = cos
- (co2 : _) = cos1
+ co' = opt_co env sym co
- ty1' = substTy env co1
- ty2' = substTy env co2
+opt_co' env sym (InstCo co ty)
+ -- See if the first arg is already a forall
+ -- ...then we can just extend the current substitution
+ | Just (tv, co_body) <- splitForAllCo_maybe co
+ = opt_co (extendTvSubst env tv ty') sym co_body
- -- These opt_cos have the sym pushed into them
- opt_co1 = opt_co env sym co1
- opt_co2 = opt_co env sym co2
+ -- See if it is a forall after optimization
+ | Just (tv, co'_body) <- splitForAllCo_maybe co'
+ = substCoWithTy tv ty' co'_body -- An inefficient one-variable substitution
- the_unary_opt_co = TyConApp tc [opt_co1]
+ | otherwise = InstCo co' ty'
- opt_lr sel = case splitAppTy_maybe opt_co1 of
- Nothing -> the_unary_opt_co
- Just lr -> sel lr
- opt_csel sel = case splitCoPredTy_maybe opt_co1 of
- Nothing -> the_unary_opt_co
- Just lr -> sel lr
+ where
+ co' = opt_co env sym co
+ ty' = substTy env ty
-------------
-opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transL = zipWith opt_trans
+opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList = zipWith opt_trans
opt_trans :: NormalCo -> NormalCo -> NormalCo
opt_trans co1 co2
- | isIdNormCo co1 = co2
- | otherwise = opt_trans1 co1 co2
+ | isReflCo co1 = co2
+ | otherwise = opt_trans1 co1 co2
opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
-- First arg is not the identity
opt_trans1 co1 co2
- | isIdNormCo co2 = co1
- | otherwise = opt_trans2 co1 co2
+ | isReflCo co2 = co1
+ | otherwise = opt_trans2 co1 co2
opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
-- Neither arg is the identity
-opt_trans2 (TyConApp tc [co1a,co1b]) co2
- | tc `hasKey` transCoercionTyConKey
- = opt_trans1 co1a (opt_trans2 co1b co2)
+opt_trans2 (TransCo co1a co1b) co2
+ -- Don't know whether the sub-coercions are the identity
+ = opt_trans co1a (opt_trans co1b co2)
opt_trans2 co1 co2
| Just co <- opt_trans_rule co1 co2
= co
-opt_trans2 co1 (TyConApp tc [co2a,co2b])
- | tc `hasKey` transCoercionTyConKey
- , Just co1_2a <- opt_trans_rule co1 co2a
- = if isIdNormCo co1_2a
+opt_trans2 co1 (TransCo co2a co2b)
+ | Just co1_2a <- opt_trans_rule co1 co2a
+ = if isReflCo co1_2a
then co2b
- else opt_trans2 co1_2a co2b
+ else opt_trans1 co1_2a co2b
opt_trans2 co1 co2
- = mkTransCoercion co1 co2
+ = mkTransCo co1 co2
------
+-- Optimize coercions with a top-level use of transitivity.
opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
-opt_trans_rule (TyConApp tc1 args1) (TyConApp tc2 args2)
- | tc1 == tc2
- = case isCoercionTyCon_maybe tc1 of
- Nothing
- -> Just (TyConApp tc1 (opt_transL args1 args2))
- Just (arity, desc)
- | arity == length args1
- -> opt_trans_rule_equal_tc desc args1 args2
- | otherwise
- -> case opt_trans_rule_equal_tc desc
- (take arity args1)
- (take arity args2) of
- Just co -> Just $ mkAppTys co $
- opt_transL (drop arity args1) (drop arity args2)
- Nothing -> Nothing
-
--- Push transitivity inside apply
-opt_trans_rule co1 co2
- | Just (co1a, co1b) <- splitAppTy_maybe co1
- , Just (co2a, co2b) <- etaApp_maybe co2
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
- | Just (co2a, co2b) <- splitAppTy_maybe co2
- , Just (co1a, co1b) <- etaApp_maybe co1
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
+-- push transitivity down through matching top-level constructors.
+opt_trans_rule in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2)
+ | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $
+ TyConAppCo tc1 (opt_transList cos1 cos2)
+
+-- push transitivity through matching destructors
+opt_trans_rule in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
+ | d1 == d2
+ , co1 `compatible_co` co2
+ = fireTransRule "PushNth" in_co1 in_co2 $
+ mkNthCo d1 (opt_trans co1 co2)
+-- Push transitivity inside instantiation
+opt_trans_rule in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
+ | ty1 `eqType` ty2
+ , co1 `compatible_co` co2
+ = fireTransRule "TrPushInst" in_co1 in_co2 $
+ mkInstCo (opt_trans co1 co2) ty1
+
+-- Push transitivity inside apply
+opt_trans_rule in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
+ = fireTransRule "TrPushApp" in_co1 in_co2 $
+ mkAppCo (opt_trans co1a co2a) (opt_trans co1b co2b)
+
+-- Push transitivity inside PredCos
+opt_trans_rule in_co1@(PredCo pco1) in_co2@(PredCo pco2)
+ | Just pco' <- opt_trans_pred pco1 pco2
+ = fireTransRule "TrPushPrd" in_co1 in_co2 $
+ mkPredCo pco'
+
+opt_trans_rule co1@(TyConAppCo tc cos1) co2
+ | Just cos2 <- etaTyConAppCo_maybe tc co2
+ = ASSERT( length cos1 == length cos2 )
+ fireTransRule "EtaCompL" co1 co2 $
+ TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+opt_trans_rule co1 co2@(TyConAppCo tc cos2)
+ | Just cos1 <- etaTyConAppCo_maybe tc co1
+ = ASSERT( length cos1 == length cos2 )
+ fireTransRule "EtaCompR" co1 co2 $
+ TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+
+{- BAY: think harder about this. do we still need it?
-- Push transitivity inside (s~t)=>r
-- We re-use the CoVar rather than using mkCoPredTy
-- See Note [Subtle shadowing in coercions]
@@ -267,190 +255,162 @@ opt_trans_rule co1 co2 , isCoVar cv1
, Just (s1,t1) <- coVarKind_maybe cv1
, Just (s2,t2,r2) <- etaCoPred_maybe co2
- = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))
+ = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoType (opt_trans s1 s2) (opt_trans t1 t2)))
(opt_trans r1 r2))
| Just (cv2,r2) <- splitForAllTy_maybe co2
, isCoVar cv2
, Just (s2,t2) <- coVarKind_maybe cv2
, Just (s1,t1,r1) <- etaCoPred_maybe co1
- = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))
+ = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoType (opt_trans s1 s2) (opt_trans t1 t2)))
(opt_trans r1 r2))
+-}
-- Push transitivity inside forall
opt_trans_rule co1 co2
- | Just (tv1,r1) <- splitTypeForAll_maybe co1
- , Just (tv2,r2) <- etaForAll_maybe co2
- , let r2' = substTyWith [tv2] [TyVarTy tv1] r2
- = Just (ForAllTy tv1 (opt_trans2 r1 r2'))
-
- | Just (tv2,r2) <- splitTypeForAll_maybe co2
- , Just (tv1,r1) <- etaForAll_maybe co1
- , let r1' = substTyWith [tv1] [TyVarTy tv2] r1
- = Just (ForAllTy tv1 (opt_trans2 r1' r2))
-
+ | Just (tv1,r1) <- splitForAllCo_maybe co1
+ , Just (tv2,r2) <- etaForAllCo_maybe co2
+ , let r2' = substCoWithTy tv2 (mkTyVarTy tv1) r2
+ = fireTransRule "EtaAllL" co1 co2 $
+ mkForAllCo tv1 (opt_trans2 r1 r2')
+
+ | Just (tv2,r2) <- splitForAllCo_maybe co2
+ , Just (tv1,r1) <- etaForAllCo_maybe co1
+ , let r1' = substCoWithTy tv1 (mkTyVarTy tv2) r1
+ = fireTransRule "EtaAllR" co1 co2 $
+ mkForAllCo tv1 (opt_trans2 r1' r2)
+
+-- Push transitivity inside axioms
opt_trans_rule co1 co2
-{- Omitting for now, because unsound
- | Just (sym1, (ax_tc1, ax1_args, ax_tvs, ax_lhs, ax_rhs)) <- co1_is_axiom_maybe
- , Just (sym2, (ax_tc2, ax2_args, _, _, _)) <- co2_is_axiom_maybe
- , ax_tc1 == ax_tc2
- , sym1 /= sym2
- = Just $
- if sym1
- then substTyWith ax_tvs (opt_transL (map mkSymCoercion ax1_args) ax2_args) ax_rhs
- else substTyWith ax_tvs (opt_transL ax1_args (map mkSymCoercion ax2_args)) ax_lhs
--}
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- co1_is_axiom_maybe
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co2
- = Just $
+ -- TrPushAxR/TrPushSymAxR
+ | Just (sym, con, cos1) <- co1_is_axiom_maybe
+ , Just cos2 <- matchAxiom sym con co2
+ = fireTransRule "TrPushAxR" co1 co2 $
if sym
- then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args)
- else TyConApp ax_tc (opt_transL ax_args cos)
+ then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1)
+ else AxiomInstCo con (opt_transList cos1 cos2)
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1
- = Just $
+ -- TrPushAxL/TrPushSymAxL
+ | Just (sym, con, cos2) <- co2_is_axiom_maybe
+ , Just cos1 <- matchAxiom (not sym) con co1
+ = fireTransRule "TrPushAxL" co1 co2 $
if sym
- then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos))
- else TyConApp ax_tc (opt_transL cos ax_args)
+ then SymCo $ AxiomInstCo con (opt_transList cos2 (map mkSymCo cos1))
+ else AxiomInstCo con (opt_transList cos1 cos2)
+
+ -- TrPushAxSym/TrPushSymAx
+ | Just (sym1, con1, cos1) <- co1_is_axiom_maybe
+ , Just (sym2, con2, cos2) <- co2_is_axiom_maybe
+ , con1 == con2
+ , sym1 == not sym2
+ , let qtvs = co_ax_tvs con1
+ lhs = co_ax_lhs con1
+ rhs = co_ax_rhs con1
+ pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs)
+ , all (`elemVarSet` pivot_tvs) qtvs
+ = fireTransRule "TrPushAxSym" co1 co2 $
+ if sym2
+ then liftCoSubstWith qtvs (opt_transList cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym
+ else liftCoSubstWith qtvs (opt_transList (map mkSymCo cos1) cos2) rhs -- TrPushSymAx
where
co1_is_axiom_maybe = isAxiom_maybe co1
co2_is_axiom_maybe = isAxiom_maybe co2
opt_trans_rule co1 co2 -- Identity rule
- | (ty1,_) <- coercionKind co1
- , (_,ty2) <- coercionKind co2
- , ty1 `coreEqType` ty2
- = Just ty2
+ | Pair ty1 _ <- coercionKind co1
+ , Pair _ ty2 <- coercionKind co2
+ , ty1 `eqType` ty2
+ = fireTransRule "RedTypeDirRefl" co1 co2 $
+ Refl ty2
opt_trans_rule _ _ = Nothing
------------
-isAxiom_maybe :: Coercion -> Maybe (Bool, (TyCon, [Coercion], [TyVar], Type, Type))
-isAxiom_maybe co
- | Just (tc, args) <- splitTyConApp_maybe co
- , Just (_, desc) <- isCoercionTyCon_maybe tc
- = case desc of
- CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }
- -> Just (False, (tc, args, tvs, lhs, rhs))
- CoSym | (arg1:_) <- args
- -> case isAxiom_maybe arg1 of
- Nothing -> Nothing
- Just (sym, stuff) -> Just (not sym, stuff)
- _ -> Nothing
- | otherwise
- = Nothing
-
-matchesAxiomLhs :: [TyVar] -> Type -> Type -> Maybe [Type]
-matchesAxiomLhs tvs ty_tmpl ty
- = case tcMatchTy (mkVarSet tvs) ty_tmpl ty of
+opt_trans_pred :: Pred Coercion -> Pred Coercion -> Maybe (Pred Coercion)
+opt_trans_pred (EqPred co1a co1b) (EqPred co2a co2b)
+ = Just (EqPred (opt_trans co1a co2a) (opt_trans co1b co2b))
+opt_trans_pred (ClassP cls1 cos1) (ClassP cls2 cos2)
+ | cls1 == cls2
+ = Just (ClassP cls1 (opt_transList cos1 cos2))
+opt_trans_pred (IParam n1 co1) (IParam n2 co2)
+ | n1 == n2
+ = Just (IParam n1 (opt_trans co1 co2))
+opt_trans_pred _ _ = Nothing
+
+fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
+fireTransRule rule co1 co2 res
+ = -- pprTrace ("Trans rule fired: " ++ rule) (vcat [ppr co1, ppr co2, ppr res]) $
+ Just res
+
+-----------
+wrapSym :: Bool -> Coercion -> Coercion
+wrapSym sym co | sym = SymCo co
+ | otherwise = co
+
+-----------
+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom, [Coercion])
+isAxiom_maybe (SymCo co)
+ | Just (sym, con, cos) <- isAxiom_maybe co
+ = Just (not sym, con, cos)
+isAxiom_maybe (AxiomInstCo con cos)
+ = Just (False, con, cos)
+isAxiom_maybe _ = Nothing
+
+matchAxiom :: Bool -- True = match LHS, False = match RHS
+ -> CoAxiom -> Coercion -> Maybe [Coercion]
+-- If we succeed in matching, then *all the quantified type variables are bound*
+-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail
+matchAxiom sym (CoAxiom { co_ax_tvs = qtvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) co
+ = case liftCoMatch (mkVarSet qtvs) (if sym then lhs else rhs) co of
Nothing -> Nothing
- Just subst -> Just (map (substTyVar subst) tvs)
-
------------
-opt_trans_rule_equal_tc :: CoTyConDesc -> [Coercion] -> [Coercion] -> Maybe Coercion
--- Rules for Coercion TyCons only
-
--- Push transitivity inside instantiation
-opt_trans_rule_equal_tc desc [co1,ty1] [co2,ty2]
- | CoInst <- desc
- , ty1 `coreEqType` ty2
- , co1 `compatible_co` co2
- = Just (mkInstCoercion (opt_trans2 co1 co2) ty1)
-
-opt_trans_rule_equal_tc desc [co1] [co2]
- | CoLeft <- desc, is_compat = Just (mkLeftCoercion res_co)
- | CoRight <- desc, is_compat = Just (mkRightCoercion res_co)
- | CoCsel1 <- desc, is_compat = Just (mkCsel1Coercion res_co)
- | CoCsel2 <- desc, is_compat = Just (mkCsel2Coercion res_co)
- | CoCselR <- desc, is_compat = Just (mkCselRCoercion res_co)
- where
- is_compat = co1 `compatible_co` co2
- res_co = opt_trans2 co1 co2
-
-opt_trans_rule_equal_tc _ _ _ = Nothing
+ Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs)
-------------
compatible_co :: Coercion -> Coercion -> Bool
-- Check whether (co1 . co2) will be well-kinded
compatible_co co1 co2
- = x1 `coreEqType` x2
+ = x1 `eqType` x2
where
- (_,x1) = coercionKind co1
- (x2,_) = coercionKind co2
+ Pair _ x1 = coercionKind co1
+ Pair x2 _ = coercionKind co2
-------------
-etaForAll_maybe :: Coercion -> Maybe (TyVar, Coercion)
+etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
-- Try to make the coercion be of form (forall tv. co)
-etaForAll_maybe co
- | Just (tv, r) <- splitForAllTy_maybe co
- , not (isCoVar tv) -- Check it is a *type* forall, not a (t1~t2)=>co
+etaForAllCo_maybe co
+ | Just (tv, r) <- splitForAllCo_maybe co
= Just (tv, r)
- | (ty1,ty2) <- coercionKind co
- , Just (tv1, _) <- splitTypeForAll_maybe ty1
- , Just (tv2, _) <- splitTypeForAll_maybe ty2
+ | Pair ty1 ty2 <- coercionKind co
+ , Just (tv1, _) <- splitForAllTy_maybe ty1
+ , Just (tv2, _) <- splitForAllTy_maybe ty2
, tyVarKind tv1 `eqKind` tyVarKind tv2
- = Just (tv1, mkInstCoercion co (mkTyVarTy tv1))
+ = Just (tv1, mkInstCo co (mkTyVarTy tv1))
| otherwise
= Nothing
-etaCoPred_maybe :: Coercion -> Maybe (Coercion, Coercion, Coercion)
-etaCoPred_maybe co
- | Just (s,t,r) <- splitCoPredTy_maybe co
- = Just (s,t,r)
-
- -- co :: (s1~t1)=>r1 ~ (s2~t2)=>r2
- | (ty1,ty2) <- coercionKind co -- We know ty1,ty2 have same kind
- , Just (s1,_,_) <- splitCoPredTy_maybe ty1
- , Just (s2,_,_) <- splitCoPredTy_maybe ty2
- , typeKind s1 `eqKind` typeKind s2 -- t1,t2 have same kinds
- = Just (mkCsel1Coercion co, mkCsel2Coercion co, mkCselRCoercion co)
-
- | otherwise
- = Nothing
-
-etaApp_maybe :: Coercion -> Maybe (Coercion, Coercion)
--- Split a coercion g :: t1a t1b ~ t2a t2b
--- into (left g, right g) if possible
-etaApp_maybe co
- | Just (co1, co2) <- splitAppTy_maybe co
- = Just (co1, co2)
-
- | (ty1,ty2) <- coercionKind co
- , Just (ty1a, _) <- splitAppTy_maybe ty1
- , Just (ty2a, _) <- splitAppTy_maybe ty2
- , typeKind ty1a `eqKind` typeKind ty2a
- = Just (mkLeftCoercion co, mkRightCoercion co)
-
- | otherwise
- = Nothing
-
--------------
-splitTypeForAll_maybe :: Type -> Maybe (TyVar, Type)
--- Returns Just only for a *type* forall, not a (t1~t2)=>co
-splitTypeForAll_maybe ty
- | Just (tv, rty) <- splitForAllTy_maybe ty
- , not (isCoVar tv)
- = Just (tv, rty)
+etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
+-- If possible, split a coercion
+-- g :: T s1 .. sn ~ T t1 .. tn
+-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
+etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2)
+ = ASSERT( tc == tc2 ) Just cos2
+
+etaTyConAppCo_maybe tc co
+ | isDecomposableTyCon tc
+ , Pair ty1 ty2 <- coercionKind co
+ , Just (tc1, tys1) <- splitTyConApp_maybe ty1
+ , Just (tc2, tys2) <- splitTyConApp_maybe ty2
+ , tc1 == tc2
+ , let n = length tys1
+ = ASSERT( tc == tc1 )
+ ASSERT( n == length tys2 )
+ Just (decomposeCo n co)
+ -- NB: n might be <> tyConArity tc
+ -- e.g. data family T a :: * -> *
+ -- g :: T a b ~ T c d
| otherwise
= Nothing
-
--------------
-isIdNormCo :: NormalCo -> Bool
--- Cheap identity test: look for coercions with no coercion variables at all
--- So it'll return False for (sym g `trans` g)
-isIdNormCo ty = go ty
- where
- go (TyVarTy tv) = not (isCoVar tv)
- go (AppTy t1 t2) = go t1 && go t2
- go (FunTy t1 t2) = go t1 && go t2
- go (ForAllTy tv ty) = go (tyVarKind tv) && go ty
- go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys
- go (PredTy (IParam _ ty)) = go ty
- go (PredTy (ClassP _ tys)) = all go tys
- go (PredTy (EqPred t1 t2)) = go t1 && go t2
\end{code}
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index adb04700ca..1d8d48a773 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -13,7 +13,9 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, SynTyConRhs(..), - CoTyConDesc(..), + + -- ** Coercion axiom constructors + CoAxiom(..), coAxiomName, coAxiomArity, -- ** Constructing TyCons mkAlgTyCon, @@ -25,7 +27,6 @@ module TyCon( mkTupleTyCon, mkSynTyCon, mkSuperKindTyCon, - mkCoercionTyCon, mkForeignTyCon, mkAnyTyCon, @@ -35,14 +36,13 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isClosedSynTyCon, + isSynTyCon, isClosedSynTyCon, isSuperKindTyCon, isDecomposableTyCon, - isCoercionTyCon, isCoercionTyCon_maybe, isForeignTyCon, isAnyTyCon, tyConHasKind, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, + isNewTyCon, isAbstractTyCon, isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, isUnLiftedTyCon, isGadtSyntaxTyCon, @@ -63,8 +63,8 @@ module TyCon( tyConParent, tyConClass_maybe, tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe, - synTyConDefn, synTyConRhs, synTyConType, - tyConExtName, -- External name for foreign types + synTyConDefn, synTyConRhs, synTyConType, + tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, tupleTyConBoxity, @@ -72,7 +72,7 @@ module TyCon( -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, makeTyConAbstract, - newTyConCo_maybe, + newTyConCo, newTyConCo_maybe, -- * Primitive representations of Types PrimRep(..), @@ -113,7 +113,7 @@ Note [Type synonym families] * Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon -* From the user's point of view (F Int) and Bool are simply +* From the user's point of view (F Int) and Bool are simply equivalent types. * A Haskell 98 type synonym is a degenerate form of a type synonym @@ -152,6 +152,23 @@ Note [Type synonym families] TyCon. In turn this means that type and data families can be treated uniformly. +* Translation of type family decl: + type family F a :: * + translates to + a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon + +* Translation of type instance decl: + type instance F [a] = Maybe a + translates to + A SynTyCon 'R:FList a', whose + SynTyConRhs is (SynonymTyCon (Maybe a)) + TyConParent is (FamInstTyCon F [a] co) + where co :: F [a] ~ R:FList a + Notice that we introduce a gratuitous vanilla type synonym + type R:FList a = Maybe a + solely so that type and data families can be treated more + uniformly, via a single FamInstTyCon descriptor + * In the future we might want to support * closed type families (esp when we have proper kinds) * injective type families (allow decomposition) @@ -169,6 +186,8 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + * The user does not see any "equivalent types" as he did with type synonym families. He just sees constructors with types T1 :: T Int @@ -266,9 +285,6 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs -- -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor of kind @*@ -- --- 5) Type coercions! This is because we represent a coercion from @t1@ to @t2@ --- as a 'Type', where that type has kind @t1 ~ t2@. See "Coercion" for more on this --- -- This data type also encodes a number of primitive, built in type constructors such as those -- for function and tuple types. data TyCon @@ -381,17 +397,6 @@ data TyCon -- holds the name of the imported thing } - -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@. - -- INVARIANT: Coercion TyCons are always fully applied - -- But note that a CoTyCon can be *over*-saturated in a type. - -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int]) - | CoTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConArity :: Arity, - coTcDesc :: CoTyConDesc - } - -- | Any types. Like tuples, this is a potentially-infinite family of TyCons -- one for each distinct Kind. They have no values at all. -- Because there are infinitely many of them (like tuples) they are @@ -401,7 +406,7 @@ data TyCon | AnyTyCon { tyConUnique :: Unique, tyConName :: Name, - tc_kind :: Kind -- Never = *; that is done via PrimTyCon + tc_kind :: Kind -- Never = *; that is done via PrimTyCon -- See Note [Any types] in TysPrim } @@ -475,18 +480,14 @@ data AlgTyConRhs -- shorter than the declared arity of the 'TyCon'. -- See Note [Newtype eta] - - nt_co :: Maybe TyCon -- ^ A 'TyCon' (which is always a 'CoTyCon') that can - -- have a 'Coercion' extracted from it to create - -- the @newtype@ from the representation 'Type'. - -- - -- This field is optional for non-recursive @newtype@s only. - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check Trac #1072. + nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from + -- the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check Trac #1072. } -- | Extract those 'DataCon's that we are able to learn about. Note @@ -546,7 +547,7 @@ data TyConParent -- and Note [Type synonym families] TyCon -- The family TyCon [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - TyCon -- The coercion constructor + CoAxiom -- The coercion constructor -- E.g. data intance T [a] = ... -- gives a representation tycon: @@ -577,20 +578,6 @@ data SynTyConRhs -- | A type synonym family e.g. @type family F x y :: * -> *@ | SynFamilyTyCon - --------------------- -data CoTyConDesc - = CoSym | CoTrans - | CoLeft | CoRight - | CoCsel1 | CoCsel2 | CoCselR - | CoInst - - | CoAxiom -- C tvs : F lhs-tys ~ rhs-ty - { co_ax_tvs :: [TyVar] - , co_ax_lhs :: Type - , co_ax_rhs :: Type } - - | CoUnsafe \end{code} Note [Enumeration types] @@ -689,6 +676,31 @@ so the coercion tycon CoT must have %************************************************************************ %* * + Coercion axioms +%* * +%************************************************************************ + +\begin{code} +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. +data CoAxiom + = CoAxiom -- type equality axiom. + { co_ax_unique :: Unique -- unique identifier + , co_ax_name :: Name -- name for pretty-printing + , co_ax_tvs :: [TyVar] -- bound type variables + , co_ax_lhs :: Type -- left-hand side of the equality + , co_ax_rhs :: Type -- right-hand side of the equality + } + +coAxiomArity :: CoAxiom -> Arity +coAxiomArity ax = length (co_ax_tvs ax) + +coAxiomName :: CoAxiom -> Name +coAxiomName = co_ax_name +\end{code} + + +%************************************************************************ +%* * \subsection{PrimRep} %* * %************************************************************************ @@ -880,17 +892,6 @@ mkSynTyCon name kind tyvars rhs parent synTcParent = parent } --- | Create a coercion 'TyCon' -mkCoercionTyCon :: Name -> Arity - -> CoTyConDesc - -> TyCon -mkCoercionTyCon name arity desc - = CoTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConArity = arity, - coTcDesc = desc } - mkAnyTyCon :: Name -> Kind -> TyCon mkAnyTyCon name kind = AnyTyCon { tyConName = name, @@ -968,11 +969,11 @@ isNewTyCon _ = False -- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands -- into, and (possibly) a coercion from the representation type to the @newtype@. -- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon) +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom) unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = mb_co, + algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }}) - = Just (tvs, rhs, mb_co) + = Just (tvs, rhs, co) unwrapNewTyCon_maybe _ = Nothing isProductTyCon :: TyCon -> Bool @@ -1004,9 +1005,8 @@ isSynTyCon _ = False isDecomposableTyCon :: TyCon -> Bool -- True iff we can decompose (T a b c) into ((T a b) c) --- Specifically NOT true of synonyms (open and otherwise) and coercions +-- Specifically NOT true of synonyms (open and otherwise) isDecomposableTyCon (SynTyCon {}) = False -isDecomposableTyCon (CoTyCon {}) = False isDecomposableTyCon _other = True -- | Is this an algebraic 'TyCon' declared with the GADT syntax? @@ -1048,7 +1048,7 @@ isInjectiveTyCon tc = not (isSynTyCon tc) -- Ultimately we may have injective associated types -- in which case this test will become more interesting -- - -- It'd be unusual to call isInjectiveTyCon on a regular H98 + -- It'd be unusual to call isInjectiveTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not injective! @@ -1113,19 +1113,6 @@ isAnyTyCon :: TyCon -> Bool isAnyTyCon (AnyTyCon {}) = True isAnyTyCon _ = False --- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of --- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the --- appropriate kind -isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, CoTyConDesc) -isCoercionTyCon_maybe (CoTyCon {tyConArity = ar, coTcDesc = desc}) - = Just (ar, desc) -isCoercionTyCon_maybe _ = Nothing - --- | Is this a 'TyCon' that represents a coercion? -isCoercionTyCon :: TyCon -> Bool -isCoercionTyCon (CoTyCon {}) = True -isCoercionTyCon _ = False - -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is -- read). @@ -1155,14 +1142,15 @@ isImplicitTyCon _other = True \begin{code} tcExpandTyCon_maybe, coreExpandTyCon_maybe :: TyCon - -> [Type] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,Type)], + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], Type, - [Type]) -- ^ Returns a 'TyVar' substitution, the body type - -- of the synonym (not yet substituted) and any arguments - -- remaining from the application + [tyco]) -- ^ Returns a 'TyVar' substitution, the body type + -- of the synonym (not yet substituted) and any arguments + -- remaining from the application --- ^ Used to create the view the /typechecker/ has on 'TyCon's. We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' +-- ^ Used to create the view the /typechecker/ has on 'TyCon's. +-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys @@ -1170,26 +1158,21 @@ tcExpandTyCon_maybe _ _ = Nothing --------------- --- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe', +-- ^ Used to create the view /Core/ has on 'TyCon's. We expand +-- not only closed synonyms like 'tcExpandTyCon_maybe', -- but also non-recursive @newtype@s -coreExpandTyCon_maybe (AlgTyCon { - algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys - = case etad_rhs of -- Don't do this in the pattern match, lest we accidentally - -- match the etad_rhs of a *recursive* newtype - (tvs,rhs) -> expand tvs rhs tys - coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys ---------------- -expand :: [TyVar] -> Type -- Template - -> [Type] -- Args - -> Maybe ([(TyVar,Type)], Type, [Type]) -- Expansion +expand :: [TyVar] -> Type -- Template + -> [a] -- Args + -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion expand tvs rhs tys = case n_tvs `compare` length tys of LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) EQ -> Just (tvs `zip` tys, rhs, []) - GT -> Nothing + GT -> Nothing where n_tvs = length tvs \end{code} @@ -1212,7 +1195,6 @@ tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon tyConHasKind :: TyCon -> Bool tyConHasKind (SuperKindTyCon {}) = False -tyConHasKind (CoTyCon {}) = False tyConHasKind _ = True -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors @@ -1265,9 +1247,14 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) -- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something -- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon' -- is not a @newtype@, returns @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe TyCon -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co -newTyConCo_maybe _ = Nothing +newTyConCo_maybe :: TyCon -> Maybe CoAxiom +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) -- | Find the primitive representation of a 'TyCon' tyConPrimRep :: TyCon -> PrimRep @@ -1337,6 +1324,7 @@ tyConParent (AlgTyCon {algTcParent = parent}) = parent tyConParent (SynTyCon {synTcParent = parent}) = parent tyConParent _ = NoParentTyCon +---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a family instance, be that for a synonym or an -- algebraic family instance? isFamInstTyCon :: TyCon -> Bool @@ -1344,7 +1332,7 @@ isFamInstTyCon tc = case tyConParent tc of FamInstTyCon {} -> True _ -> False -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], TyCon) +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom) tyConFamInstSig_maybe tc = case tyConParent tc of FamInstTyCon f ts co_tc -> Just (f, ts, co_tc) @@ -1361,7 +1349,7 @@ tyConFamInst_maybe tc -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents -- a coercion identifying the representation type with the type instance family. -- Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon +tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom tyConFamilyCoercion_maybe tc = case tyConParent tc of FamInstTyCon _ _ co -> Just co @@ -1395,18 +1383,6 @@ instance Ord TyCon where instance Uniquable TyCon where getUnique tc = tyConUnique tc -instance Outputable CoTyConDesc where - ppr CoSym = ptext (sLit "SYM") - ppr CoTrans = ptext (sLit "TRANS") - ppr CoLeft = ptext (sLit "LEFT") - ppr CoRight = ptext (sLit "RIGHT") - ppr CoCsel1 = ptext (sLit "CSEL1") - ppr CoCsel2 = ptext (sLit "CSEL2") - ppr CoCselR = ptext (sLit "CSELR") - ppr CoInst = ptext (sLit "INST") - ppr CoUnsafe = ptext (sLit "UNSAFE") - ppr (CoAxiom {}) = ptext (sLit "AXIOM") - instance Outputable TyCon where ppr tc = ppr (getName tc) @@ -1421,4 +1397,34 @@ instance Data.Data TyCon where toConstr _ = abstractConstr "TyCon" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "TyCon" + +------------------- +instance Eq CoAxiom where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord CoAxiom where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = getUnique a `compare` getUnique b + +instance Uniquable CoAxiom where + getUnique = co_ax_unique + +instance Outputable CoAxiom where + ppr = ppr . getName + +instance NamedThing CoAxiom where + getName = co_ax_name + +instance Data.Typeable CoAxiom where + typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") [] + +instance Data.Data CoAxiom where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" \end{code} diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 5f348efd35..1958a5cea8 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -20,7 +20,8 @@ module Type ( -- $type_classification -- $representation_types - TyThing(..), Type, PredType(..), ThetaType, + TyThing(..), Type, Pred(..), PredType, ThetaType, + Var, TyVar, isTyVar, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, @@ -45,14 +46,20 @@ module Type ( -- (Type families) tyFamInsts, predFamInsts, - -- (Source types) - mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred, + -- Pred types + mkPredTy, mkPredTys, mkFamilyTyConApp, + mkDictTy, isDictLikeTy, isClassPred, + isEqPred, allPred, mkEqPred, + mkClassPred, getClassPredTys, getClassPredTys_maybe, + isTyVarClassPred, + mkIPPred, isIPPred, -- ** Common type constructors funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, + isTyVarTy, isFunTy, isPredTy, + isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, @@ -65,8 +72,7 @@ module Type ( -- ** Common Kinds and SuperKinds liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, - - tySuperKind, coSuperKind, + tySuperKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, @@ -74,19 +80,18 @@ module Type ( -- * Type free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - expandTypeSynonyms, + exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms, typeSize, -- * Type comparison - coreEqType, coreEqType2, - tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, + eqPred, eqPredX, cmpPred, eqKind, -- * Forcing evaluation of types - seqType, seqTypes, + seqType, seqTypes, seqPred, -- * Other views onto Types - coreView, tcView, kindView, + coreView, tcView, repType, @@ -103,18 +108,22 @@ module Type ( emptyTvSubstEnv, emptyTvSubst, mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, - getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, + getTvSubstEnv, setTvSubstEnv, + zapTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList, - extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, + extendTvSubst, extendTvSubstList, + isInScope, composeTvSubst, zipTyEnv, isEmptyTvSubst, unionTvSubst, -- ** Performing substitution on types substTy, substTys, substTyWith, substTysWith, substTheta, - substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, + substPred, substTyVar, substTyVars, substTyVarBndr, + deShadowTy, lookupTyVar, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, + pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprSourceTyCon ) where @@ -133,8 +142,11 @@ import VarSet import Class import TyCon +import TysPrim -- others +import BasicTypes ( IPName ) +import Name ( Name ) import StaticFlags import Util import Outputable @@ -283,14 +295,6 @@ expandTypeSynonyms ty go_pred (ClassP c ts) = ClassP c (map go ts) go_pred (IParam ip t) = IParam ip (go t) go_pred (EqPred t1 t2) = EqPred (go t1) (go t2) - ------------------------------------------------ -{-# INLINE kindView #-} -kindView :: Kind -> Maybe Kind --- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's - --- For the moment, we don't even handle synonyms in kinds -kindView _ = Nothing \end{code} @@ -305,12 +309,6 @@ kindView _ = Nothing TyVarTy ~~~~~~~ \begin{code} -mkTyVarTy :: TyVar -> Type -mkTyVarTy = TyVarTy - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -- | Attempts to obtain the type variable underlying a 'Type', and panics with the -- given message if this is not a type variable type. See also 'getTyVar_maybe' getTyVar :: String -> Type -> TyVar @@ -427,8 +425,7 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -- ^ Creates a function type from the given argument and result type -mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res -mkFunTy arg res = FunTy arg res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys @@ -496,20 +493,6 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) ~~~~~~~~ \begin{code} --- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. --- Applies its arguments to the constructor from left to right -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] - -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -612,13 +595,16 @@ repType ty = go [] ty where go :: [TyCon] -> Type -> Type - go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms - = go rec_nts ty' - - go rec_nts (ForAllTy _ ty) -- Look through foralls + go rec_nts (ForAllTy _ ty) -- Look through foralls = go rec_nts ty - go rec_nts (TyConApp tc tys) -- Expand newtypes + go rec_nts (PredTy p) -- Expand predicates + = go rec_nts (predTypeRep p) + + go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms + | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys + = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys = go rec_nts' ty' @@ -756,13 +742,32 @@ applyTysD doc orig_fun_ty arg_tys %************************************************************************ %* * -\subsection{Source types} + Pred %* * %************************************************************************ -Source types are always lifted. +Polymorphic functions over Pred -The key function is predTypeRep which gives the representation of a source type: +\begin{code} +allPred :: (a -> Bool) -> Pred a -> Bool +allPred p (ClassP _ ts) = all p ts +allPred p (IParam _ t) = p t +allPred p (EqPred t1 t2) = p t1 && p t2 + +isClassPred :: Pred a -> Bool +isClassPred (ClassP {}) = True +isClassPred _ = False + +isEqPred :: Pred a -> Bool +isEqPred (EqPred {}) = True +isEqPred _ = False + +isIPPred :: Pred a -> Bool +isIPPred (IParam {}) = True +isIPPred _ = False +\end{code} + +Make PredTypes \begin{code} mkPredTy :: PredType -> Type @@ -771,91 +776,115 @@ mkPredTy pred = PredTy pred mkPredTys :: ThetaType -> [Type] mkPredTys preds = map PredTy preds -isEqPred :: PredType -> Bool -isEqPred (EqPred _ _) = True -isEqPred _ = False - predTypeRep :: PredType -> Type -- ^ Convert a 'PredType' to its representation type. However, it unwraps -- only the outermost level; for example, the result might be a newtype application predTypeRep (IParam _ ty) = ty predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys - -- Result might be a newtype application, but the consumer will - -- look through that too if necessary -predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) +predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2] -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys +splitPredTy_maybe :: Type -> Maybe PredType +-- Returns Just for predicates only +splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty' +splitPredTy_maybe (PredTy p) = Just p +splitPredTy_maybe _ = Nothing --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > data T [a] = ... --- --- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' -pprSourceTyCon :: TyCon -> SDoc -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon - -isDictTy :: Type -> Bool -isDictTy ty = case splitTyConApp_maybe ty of - Just (tc, _) -> isClassTyCon tc - Nothing -> False +isPredTy :: Type -> Bool +isPredTy ty = isJust (splitPredTy_maybe ty) \end{code} +--------------------- Equality types --------------------------------- +\begin{code} +isReflPredTy :: Type -> Bool +isReflPredTy ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> ty1 `eqType` ty2 + _ -> False + +splitEqPredTy_maybe :: Type -> Maybe (Type,Type) +splitEqPredTy_maybe ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> Just (ty1,ty2) + _ -> Nothing + +isEqPredTy :: Type -> Bool +isEqPredTy ty = case splitPredTy_maybe ty of + Just (EqPred {}) -> True + _ -> False + +-- | Creates a type equality predicate +mkEqPred :: (a, a) -> Pred a +mkEqPred (ty1, ty2) = EqPred ty1 ty2 +\end{code} -%************************************************************************ -%* * - The free variables of a type -%* * -%************************************************************************ - +--------------------- Dictionary types --------------------------------- \begin{code} -tyVarsOfType :: Type -> TyVarSet --- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym -tyVarsOfType (TyVarTy tv) = unitVarSet tv -tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys -tyVarsOfType (PredTy sty) = tyVarsOfPred sty -tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res -tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg -tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder - -- can mention type variables! - | isTyVar tv = inner_tvs `delVarSet` tv - | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) ) - inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv) - where - inner_tvs = tyVarsOfType ty +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = ClassP clas tys -tyVarsOfTypes :: [Type] -> TyVarSet -tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys +isDictTy :: Type -> Bool +isDictTy ty = case splitPredTy_maybe ty of + Just p -> isClassPred p + Nothing -> False + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys +isTyVarClassPred _ = False + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) +getClassPredTys_maybe _ = Nothing + +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys (ClassP clas tys) = (clas, tys) +getClassPredTys _ = panic "getClassPredTys" + +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = mkPredTy (ClassP clas tys) + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False +\end{code} -tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (IParam _ ty) = tyVarsOfType ty -tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys -tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. <blah>) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + +--------------------- Implicit parameters --------------------------------- -tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet +\begin{code} +mkIPPred :: IPName Name -> Type -> PredType +mkIPPred ip ty = IParam ip ty \end{code} - %************************************************************************ %* * Size @@ -867,14 +896,9 @@ typeSize :: Type -> Int typeSize (TyVarTy _) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (PredTy p) = predSize p +typeSize (PredTy p) = predSize typeSize p typeSize (ForAllTy _ t) = 1 + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) - -predSize :: PredType -> Int -predSize (IParam _ t) = 1 + typeSize t -predSize (ClassP _ ts) = 1 + sum (map typeSize ts) -predSize (EqPred t1 t2) = typeSize t1 + typeSize t2 \end{code} @@ -904,8 +928,37 @@ predFamInsts :: PredType -> [(TyCon, [Type])] predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys) predFamInsts (IParam _ ty) = tyFamInsts ty predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 -\end{code} +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon +\end{code} %************************************************************************ %* * @@ -924,6 +977,7 @@ isUnLiftedType :: Type -> Bool isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty +isUnLiftedType (PredTy p) = isEqPred p isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc isUnLiftedType _ = False @@ -977,7 +1031,8 @@ isStrictType _ = False -- poking the dictionary component, which is wrong.) isStrictPred :: PredType -> Bool isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -isStrictPred _ = False +isStrictPred (EqPred {}) = True +isStrictPred (IParam {}) = False \end{code} \begin{code} @@ -994,6 +1049,64 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of %************************************************************************ %* * + 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! +Here's the example that Ralf Laemmel showed me: + foo :: (forall a. C u a -> C u a) -> u + mappend :: Monoid u => u -> u -> u + + bar :: Monoid u => u + bar = foo (\t -> t `mappend` t) +We have to generalise at the arg to f, and we don't +want to capture the constraint (Monad (C u a)) because +it appears to mention a. Pretty silly, but it was useful to him. + +exactTyVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It's also used in the +smart-app checking code --- see TcExpr.tcIdApp + +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. + +\begin{code} +exactTyVarsOfType :: Type -> TyVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (PredTy ty) = go_pred ty + go (FunTy arg res) = go arg `unionVarSet` go res + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + + go_pred (IParam _ ty) = go ty + go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 + +exactTyVarsOfTypes :: [Type] -> TyVarSet +exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys +\end{code} + + +%************************************************************************ +%* * \subsection{Sequencing on types} %* * %************************************************************************ @@ -1003,7 +1116,7 @@ seqType :: Type -> () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (PredTy p) = seqPred p +seqType (PredTy p) = seqPred seqType p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty @@ -1011,115 +1124,40 @@ seqTypes :: [Type] -> () seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys -seqPred :: PredType -> () -seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (IParam n ty) = n `seq` seqType ty -seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2 +seqPred :: (a -> ()) -> Pred a -> () +seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys +seqPred seqt (IParam n ty) = n `seq` seqt ty +seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2 \end{code} %************************************************************************ %* * - Equality for Core types + Comparision for types (We don't use instances so that we know where it happens) %* * %************************************************************************ -Note that eqType works right even for partial applications of newtypes. -See Note [Newtype eta] in TyCon.lhs - \begin{code} --- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.) -coreEqType :: Type -> Type -> Bool -coreEqType t1 t2 = coreEqType2 rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) - -coreEqType2 :: RnEnv2 -> Type -> Type -> Bool -coreEqType2 rn_env t1 t2 - = eq rn_env t1 t2 - where - eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 - eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2 - eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (FunTy s1 t1) (FunTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, all2 (eq env) tys1 tys2 = True - -- The lengths should be equal because - -- the two types have the same kind - -- NB: if the type constructors differ that does not - -- necessarily mean that the types aren't equal - -- (synonyms, newtypes) - -- Even if the type constructors are the same, but the arguments - -- differ, the two types could be the same (e.g. if the arg is just - -- ignored in the RHS). In both these cases we fall through to an - -- attempt to expand one side or the other. - - -- Now deal with newtypes, synonyms, pred-tys - eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2 - | Just t2' <- coreView t2 = eq env t1 t2' - - -- Fall through case; not equal! - eq _ _ _ = False -\end{code} - - -%************************************************************************ -%* * - Comparision for source types - (We don't use instances so that we know where it happens) -%* * -%************************************************************************ +eqKind :: Kind -> Kind -> Bool +eqKind = eqType -\begin{code} -tcEqType :: Type -> Type -> Bool +eqType :: Type -> Type -> Bool -- ^ Type equality on source types. Does not look through @newtypes@ or -- 'PredType's, but it does look through type synonyms. -tcEqType t1 t2 = isEqual $ cmpType t1 t2 - -tcEqTypes :: [Type] -> [Type] -> Bool -tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 - -tcCmpType :: Type -> Type -> Ordering --- ^ Type ordering on source types. Does not look through @newtypes@ or --- 'PredType's, but it does look through type synonyms. -tcCmpType t1 t2 = cmpType t1 t2 - -tcCmpTypes :: [Type] -> [Type] -> Ordering -tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 +eqType t1 t2 = isEqual $ cmpType t1 t2 -tcEqPred :: PredType -> PredType -> Bool -tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool -tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -tcCmpPred :: PredType -> PredType -> Ordering -tcCmpPred p1 p2 = cmpPred p1 p2 +eqPred :: PredType -> PredType -> Bool +eqPred p1 p2 = isEqual $ cmpPred p1 p2 -tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool -tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -\end{code} - -\begin{code} --- | Checks whether the second argument is a subterm of the first. (We don't care --- about binders, as we are only interested in syntactic subterms.) -tcPartOfType :: Type -> Type -> Bool -tcPartOfType t1 t2 - | tcEqType t1 t2 = True -tcPartOfType t1 t2 - | Just t2' <- tcView t2 = tcPartOfType t1 t2' -tcPartOfType _ (TyVarTy _) = False -tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2 -tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 -tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 -tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2 -tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts - -tcPartOfPred :: Type -> PredType -> Bool -tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2 -tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts -tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 +eqPredX :: RnEnv2 -> PredType -> PredType -> Bool +eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 \end{code} Now here comes the real worker @@ -1141,8 +1179,13 @@ cmpPred p1 p2 = cmpPredX rn_env p1 p2 rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2)) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2 - | Just t2' <- tcView t2 = cmpTypeX env t1 t2' +cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 + | Just t2' <- coreView t2 = cmpTypeX env t1 t2' +-- We expand predicate types, because in Core-land we have +-- lots of definitions like +-- fOrdBool :: Ord Bool +-- fOrdBool = D:Ord .. .. .. +-- So the RHS has a data type cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 @@ -1199,8 +1242,8 @@ PredTypes are used as a FM key in TcSimplify, so we take the easy path and make them an instance of Ord \begin{code} -instance Eq PredType where { (==) = tcEqPred } -instance Ord PredType where { compare = tcCmpPred } +instance Eq PredType where { (==) = eqPred } +instance Ord PredType where { compare = cmpPred } \end{code} @@ -1211,81 +1254,6 @@ instance Ord PredType where { compare = tcCmpPred } %************************************************************************ \begin{code} --- | Type substitution --- --- #tvsubst_invariant# --- The following invariants must hold of a 'TvSubst': --- --- 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 substition is only applied ONCE! This is because --- in general such application will not reached a fixed point. -data TvSubst - = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- The substitution itself - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - -{- ---------------------------------------------------------- - -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TvSubsts to instantiate things, and we might instantiate - forall a b. ty -\with the types - [a, b], or [b, a]. -So the substition 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 substition that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - *************************************************** - *** So a TvSubst must be applied precisely once *** - *************************************************** - -A TvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the TvSubstEnv is empty: -if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt 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 substTyVarBndr, 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 - - --------------------------------------------------------------- -} - --- | A substitition of 'Type's for 'TyVar's -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TvSubst (with the apply-once - -- invariant discussed in Note [Apply 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 - emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv @@ -1303,11 +1271,11 @@ composeTvSubst in_scope env1 env2 subst1 = TvSubst in_scope env1 emptyTvSubst :: TvSubst -emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv +emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv isEmptyTvSubst :: TvSubst -> Bool -- See Note [Extending the TvSubstEnv] -isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env +isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst mkTvSubst = TvSubst @@ -1321,34 +1289,34 @@ getTvInScope (TvSubst in_scope _) = in_scope isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope -notElemTvSubst :: TyVar -> TvSubst -> Bool -notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env) +notElemTvSubst :: TyCoVar -> TvSubst -> Bool +notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst -setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env +setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv zapTvSubstEnv :: TvSubst -> TvSubst zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv extendTvInScope :: TvSubst -> Var -> TvSubst -extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env +extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv extendTvInScopeList :: TvSubst -> [Var] -> TvSubst -extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env +extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst -extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty) +extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst -extendTvSubstList (TvSubst in_scope env) tvs tys - = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) +extendTvSubstList (TvSubst in_scope tenv) tvs tys + = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) unionTvSubst :: TvSubst -> TvSubst -> TvSubst -- Works when the ranges are disjoint -unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2) - = ASSERT( not (env1 `intersectsVarEnv` env2) ) +unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) TvSubst (in_scope1 `unionInScope` in_scope2) - (env1 `plusVarEnv` env2) + (tenv1 `plusVarEnv` tenv2) -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck @@ -1370,7 +1338,7 @@ unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2) -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming -- environment, hence "open" mkOpenTvSubst :: TvSubstEnv -> TvSubst -mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env +mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming -- environment, hence "open" @@ -1396,7 +1364,7 @@ zipTopTvSubst tyvars tys zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn && (length tyvars /= length tys) - = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv + = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv | otherwise = zip_ty_env tyvars tys emptyVarEnv @@ -1421,10 +1389,10 @@ zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr -- zip_ty_env _ _ env = env instance Outputable TvSubst where - ppr (TvSubst ins env) + ppr (TvSubst ins tenv) = brackets $ sep[ ptext (sLit "TvSubst"), nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Env:") <+> ppr env) ] + nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] \end{code} %************************************************************************ @@ -1499,29 +1467,34 @@ subst_ty subst ty ForAllTy tv' $! (subst_ty subst' ty) substTyVar :: TvSubst -> TyVar -> Type -substTyVar subst@(TvSubst _ _) tv - = case lookupTyVar subst tv of { - Nothing -> TyVarTy tv; - Just ty -> ty -- See Note [Apply Once] - } +substTyVar (TvSubst _ tenv) tv + | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] + | otherwise = ASSERT( isTyVar tv ) TyVarTy tv + -- We do not require that the tyvar is in scope + -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) + -- and it's a nuisance to bring all the free vars of tau into + -- scope --- and then force that thunk at every tyvar + -- Instead we have an ASSERT in substTyVarBndr to check for capture substTyVars :: TvSubst -> [TyVar] -> [Type] substTyVars subst tvs = map (substTyVar subst) tvs lookupTyVar :: TvSubst -> TyVar -> Maybe Type -- See Note [Extending the TvSubst] -lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv +lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv -substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVarBndr subst@(TvSubst in_scope env) old_var - = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope tenv) old_var + = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) + (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where - is_co_var = isCoVar old_var + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - new_env | no_change = delVarEnv env old_var - | otherwise = extendVarEnv env old_var (TyVarTy new_var) + _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) + -- Check that we are not capturing something in the substitution - no_change = new_var == old_var && not is_co_var + no_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 TvSubst] @@ -1532,14 +1505,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x - new_var = uniqAway in_scope subst_old_var + new_var = uniqAway in_scope old_var -- The uniqAway part makes sure the new variable is not already in scope - - subst_old_var -- subst_old_var is old_var with the substitution applied to its kind - -- It's only worth doing the substitution for coercions, - -- becuase only they can have free type variables - | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var)) - | otherwise = old_var \end{code} ---------------------------------------------------- diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 85514091a4..446341db80 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -7,44 +7,35 @@ \begin{code} -- We expose the relevant stuff from this module via the Type module {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} - +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module TypeRep ( TyThing(..), Type(..), - PredType(..), -- to friends + Pred(..), -- to friends - Kind, ThetaType, -- Synonyms + Kind, SuperKind, + PredType, ThetaType, -- Synonyms - funTyCon, funTyConName, + -- Functions over types + mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, + isLiftedTypeKind, isCoercionKind, - -- Pretty-printing + -- Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThing, pprTyThingCategory, - pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, - - -- Kinds - liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, - isLiftedTypeKindCon, isLiftedTypeKind, - mkArrowKind, mkArrowKinds, isCoercionKind, - coVarPred, - - -- Kind constructors... - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, - - -- And their names - unliftedTypeKindTyConName, openTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName, - liftedTypeKindTyConName, - - -- Super Kinds - tySuperKind, coSuperKind, - isTySuperKind, isCoSuperKind, - tySuperKindTyCon, coSuperKindTyCon, - - pprKind, pprParendKind + pprPredTy, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, + Prec(..), maybeParen, pprTcApp, pprTypeNameApp, + pprPrefixApp, pprPred, pprArrowChain, pprThetaArrow, + + -- Free variables + tyVarsOfType, tyVarsOfTypes, + tyVarsOfPred, tyVarsOfTheta, + varsOfPred, varsOfTheta, + predSize, + + -- Substitutions + TvSubst(..), TvSubstEnv ) where #include "HsVersions.h" @@ -53,6 +44,8 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName ) -- friends: import Var +import VarEnv +import VarSet import Name import BasicTypes import TyCon @@ -62,9 +55,12 @@ import Class import PrelNames import Outputable import FastString +import Pair -- libraries -import Data.Data hiding ( TyCon ) +import qualified Data.Data as Data hiding ( TyCon ) +import qualified Data.Foldable as Data +import qualified Data.Traversable as Data \end{code} ---------------------- @@ -120,13 +116,14 @@ to cut all loops. The other members of the loop may be marked 'non-recursive'. \begin{code} -- | The key representation of types within the compiler data Type - = TyVarTy TyVar -- ^ Vanilla type variable + = TyVarTy TyVar -- ^ Vanilla type variable (*never* a coercion variable) | AppTy Type Type -- ^ Type application to something other than a 'TyCon'. Parameters: -- - -- 1) Function: must /not/ be a 'TyConApp', must be another 'AppTy', or 'TyVarTy' + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' -- -- 2) Argument type @@ -135,31 +132,34 @@ data Type [Type] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. -- Invariant: saturated appliations of 'FunTyCon' must -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's do appear as 'TyConApp's. + -- 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. + -- 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. | FunTy Type Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ | ForAllTy - TyVar + TyCoVar -- ^ Type *or* coercion variable; see Note [Equality-constrained types] Type -- ^ A polymorphic type | PredTy PredType -- ^ The type of evidence for a type predictate. -- Note that a @PredTy (EqPred _ _)@ can appear only as the kind - -- of a coercion variable; never as the argument or result - -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam') + -- of a coercion variable; never as the argument or result of a + -- 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam') -- See Note [PredTy], and Note [Equality predicates] - deriving (Data, Typeable) + deriving (Data.Data, Data.Typeable) -- | The key type representing kinds in the compiler. -- Invariant: a kind is always in one of these forms: @@ -177,6 +177,27 @@ type Kind = Type type SuperKind = Type \end{code} +Note [Equality-constrained types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type forall ab. (a ~ [b]) => blah +is encoded like this: + + ForAllTy (a:*) $ ForAllTy (b:*) $ + ForAllTy (wild_co : a ~ [b]) $ + blah + +That is, the "(a ~ [b]) =>" part is encode as a for-all +type with a coercion variable that is never mentioned. + +We could instead have used a FunTy with an EqPred on the +left. But we want + + * FunTy to mean RUN-TIME abstraction, + passing a real value at runtime, + + * ForAllTy to mean COMPILE-TIME abstraction, + erased at runtime + ------------------------------------- Note [PredTy] @@ -197,11 +218,13 @@ type SuperKind = Type -- > h :: (r\l) => {r} => {l::Int | r} -- -- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -data PredType - = ClassP Class [Type] -- ^ Class predicate e.g. @Eq a@ - | IParam (IPName Name) Type -- ^ Implicit parameter e.g. @?x :: Int@ - | EqPred Type Type -- ^ Equality predicate e.g @ty1 ~ ty2@ - deriving (Data, Typeable) +type PredType = Pred Type + +data Pred a -- Typically 'a' is instantiated with Type or Coercion + = ClassP Class [a] -- ^ Class predicate e.g. @Eq a@ + | IParam (IPName Name) a -- ^ Implicit parameter e.g. @?x :: Int@ + | EqPred a a -- ^ Equality predicate e.g @ty1 ~ ty2@ + deriving (Data.Data, Data.Typeable, Data.Foldable, Data.Traversable, Functor) -- | A collection of 'PredType's type ThetaType = [PredType] @@ -240,6 +263,89 @@ name (wildCoVarName), since it's not mentioned. %************************************************************************ %* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type + +\begin{code} +mkTyVarTy :: TyVar -> Type +mkTyVarTy = TyVarTy + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. +-- Applies its arguments to the constructor from left to right +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | otherwise + = TyConApp tycon tys + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = mkTyConApp tycon [] + +isLiftedTypeKind :: Kind -> Bool +-- This function is here because it's used in the pretty printer +isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey +isLiftedTypeKind _ = False + +isCoercionKind :: Kind -> Bool +-- All coercions are of form (ty1 ~ ty2) +-- This function is here rather than in Coercion, because it +-- is used in a knot-tied way to enforce invariants in Var +isCoercionKind (PredTy (EqPred {})) = True +isCoercionKind _ = False +\end{code} + + +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ + +\begin{code} +tyVarsOfPred :: PredType -> TyCoVarSet +tyVarsOfPred = varsOfPred tyVarsOfType + +tyVarsOfTheta :: ThetaType -> TyCoVarSet +tyVarsOfTheta = varsOfTheta tyVarsOfType + +tyVarsOfType :: Type -> VarSet +-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym +tyVarsOfType (TyVarTy v) = unitVarSet v +tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (PredTy sty) = varsOfPred tyVarsOfType sty +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + +tyVarsOfTypes :: [Type] -> TyVarSet +tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys + +varsOfPred :: (a -> VarSet) -> Pred a -> VarSet +varsOfPred f (IParam _ ty) = f ty +varsOfPred f (ClassP _ tys) = foldr (unionVarSet . f) emptyVarSet tys +varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2 + +varsOfTheta :: (a -> VarSet) -> [Pred a] -> VarSet +varsOfTheta f = foldr (unionVarSet . varsOfPred f) emptyVarSet + +predSize :: (a -> Int) -> Pred a -> Int +predSize size (IParam _ t) = 1 + size t +predSize size (ClassP _ ts) = 1 + sum (map size ts) +predSize size (EqPred t1 t2) = size t1 + size t2 +\end{code} + +%************************************************************************ +%* * TyThing %* * %************************************************************************ @@ -253,6 +359,7 @@ funTyCon and all the types in TysPrim. data TyThing = AnId Id | ADataCon DataCon | ATyCon TyCon + | ACoAxiom CoAxiom | AClass Class instance Outputable TyThing where @@ -263,6 +370,7 @@ pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor") +pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") pprTyThingCategory (AClass _) = ptext (sLit "Class") pprTyThingCategory (AnId _) = ptext (sLit "Identifier") pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") @@ -270,6 +378,7 @@ pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") 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 (AClass cl) = getName cl getName (ADataCon dc) = dataConName dc \end{code} @@ -277,131 +386,92 @@ instance NamedThing TyThing where -- Can't put this with the type %************************************************************************ %* * - Wired-in type constructors + Substitutions + Data type defined here to avoid unnecessary mutual recursion %* * %************************************************************************ -We define a few wired-in type constructors here to avoid module knots - \begin{code} --------------------------- --- First the TyCons... - --- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon, - openTypeKindTyCon, unliftedTypeKindTyCon, - ubxTupleKindTyCon, argTypeKindTyCon - :: TyCon -funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName, - openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName - :: Name - -funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) - -- You might think that (->) should have type (?? -> ? -> *), and you'd be right - -- But if we do that we get kind errors when saying - -- instance Control.Arrow (->) - -- becuase the expected kind is (*->*->*). The trouble is that the - -- expected/actual stuff in the unifier does not go contra-variant, whereas - -- the kind sub-typing does. Sigh. It really only matters if you use (->) in - -- a prefix way, thus: (->) Int# Int#. And this is unusual. - - -tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName -coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName - -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind - --------------------------- --- ... and now their names - -tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon -coSuperKindTyConName = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon -liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon -openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon -unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon -ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon -argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon -funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon - -mkPrimTyConName :: FastString -> Unique -> TyCon -> Name -mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) - key - (ATyCon tycon) - BuiltInSyntax - -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, - -- because they are never in scope in the source - ------------------- --- We also need Kinds and SuperKinds, locally and in TyCon - -kindTyConType :: TyCon -> Type -kindTyConType kind = TyConApp kind [] - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind - -liftedTypeKind = kindTyConType liftedTypeKindTyCon -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon -openTypeKind = kindTyConType openTypeKindTyCon -argTypeKind = kindTyConType argTypeKindTyCon -ubxTupleKind = kindTyConType ubxTupleKindTyCon +-- | Type substitution +-- +-- #tvsubst_invariant# +-- The following invariants must hold of a 'TvSubst': +-- +-- 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 substition is only applied ONCE! This is because +-- in general such application will not reached a fixed point. +data TvSubst + = TvSubst InScopeSet -- The in-scope type variables + TvSubstEnv -- Substitution of types + -- See Note [Apply Once] + -- and Note [Extending the TvSubstEnv] + +-- | A substitition of 'Type's for 'TyVar's +type TvSubstEnv = TyVarEnv Type + -- A TvSubstEnv is used both inside a TvSubst (with the apply-once + -- invariant discussed in Note [Apply 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 +\end{code} --- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ -mkArrowKind :: Kind -> Kind -> Kind -mkArrowKind k1 k2 = FunTy k1 k2 +Note [Apply Once] +~~~~~~~~~~~~~~~~~ +We use TvSubsts to instantiate things, and we might instantiate + forall a b. ty +\with the types + [a, b], or [b, a]. +So the substition 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 substition that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. --- | Iterated application of 'mkArrowKind' -mkArrowKinds :: [Kind] -> Kind -> Kind -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds + *************************************************** + *** So a TvSubst must be applied precisely once *** + *************************************************** -tySuperKind, coSuperKind :: SuperKind -tySuperKind = kindTyConType tySuperKindTyCon -coSuperKind = kindTyConType coSuperKindTyCon +A TvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. -isTySuperKind :: SuperKind -> Bool -isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey -isTySuperKind _ = False +Note [Extending the TvSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tvsubst_invariant# for the invariants that must hold. -isCoSuperKind :: SuperKind -> Bool -isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey -isCoSuperKind _ = False +This invariant allows a short-cut when the TvSubstEnv is empty: +if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- +then (substTy subst ty) does nothing. -------------------- --- Lastly we need a few functions on Kinds +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 -isLiftedTypeKindCon :: TyCon -> Bool -isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey +This invariant has several crucial consequences: -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc -isLiftedTypeKind _ = False +* In substTyVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed -isCoercionKind :: Kind -> Bool --- All coercions are of form (ty1 ~ ty2) --- This function is here rather than in Coercion, --- because it's used in a knot-tied way to enforce invariants in Var -isCoercionKind (PredTy (EqPred {})) = True -isCoercionKind _ = False +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough -coVarPred :: CoVar -> PredType -coVarPred tv - = ASSERT( isCoVar tv ) - case tyVarKind tv of - PredTy eq -> eq - other -> pprPanic "coVarPred" (ppr tv $$ ppr other) +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty \end{code} %************************************************************************ %* * -\subsection{The external interface} -%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * %************************************************************************ @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is @@ -422,43 +492,58 @@ maybeParen ctxt_prec inner_prec pretty ------------------ pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_type TopPrec ty +pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty -pprTypeApp :: NamedThing a => a -> [Type] -> SDoc --- The first arg is the tycon, or sometimes class --- Print infix if the tycon/class looks like an operator -pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType ------------------ -pprPred :: PredType -> SDoc -pprPred (ClassP cls tys) = pprClassPred cls tys -pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty -pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2) - -pprEqPred :: (Type,Type) -> SDoc -pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1 - , nest 2 (ptext (sLit "~")) - , ppr_type FunPrec ty2] +pprPredTy :: PredType -> SDoc +pprPredTy = pprPred ppr_type + +pprPred :: (Prec -> a -> SDoc) -> Pred a -> SDoc +pprPred pp (ClassP cls tys) = ppr_class_pred pp cls tys +pprPred pp (IParam ip ty) = ppr ip <> dcolon <> pp TopPrec ty +pprPred pp (EqPred ty1 ty2) = ppr_eq_pred pp (Pair ty1 ty2) + +------------ +pprEqPred :: Pair Type -> SDoc +pprEqPred = ppr_eq_pred ppr_type + +ppr_eq_pred :: (Prec -> a -> SDoc) -> Pair a -> SDoc +ppr_eq_pred pp (Pair ty1 ty2) = sep [ pp FunPrec ty1 + , nest 2 (ptext (sLit "~")) + , pp FunPrec ty2] -- Precedence looks like (->) so that we get -- Maybe a ~ Bool -- (a->a) ~ Bool -- Note parens on the latter! +------------ pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys +pprClassPred = ppr_class_pred ppr_type +ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc +ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys + +------------ pprTheta :: ThetaType -> SDoc -- pprTheta [pred] = pprPred pred -- I'm in two minds about this -pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) +pprTheta theta = parens (sep (punctuate comma (map pprPredTy theta))) + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprThetaArrow ppr_type -pprThetaArrow :: ThetaType -> SDoc -pprThetaArrow [] = empty -pprThetaArrow [pred] - | noParenPred pred = pprPred pred <+> darrow -pprThetaArrow preds = parens (sep (punctuate comma (map pprPred preds))) <+> darrow +pprThetaArrow :: (Prec -> a -> SDoc) -> [Pred a] -> SDoc +pprThetaArrow _ [] = empty +pprThetaArrow pp [pred] + | noParenPred pred = pprPred pp pred <+> darrow +pprThetaArrow pp preds = parens (sep (punctuate comma (map (pprPred pp) preds))) + <+> darrow -noParenPred :: PredType -> Bool +noParenPred :: Pred a -> Bool -- A predicate that can appear without parens before a "=>" -- C a => a -> a -- a~b => a -> b @@ -471,8 +556,9 @@ noParenPred (IParam {}) = False instance Outputable Type where ppr ty = pprType ty -instance Outputable PredType where - ppr = pprPred +instance Outputable (Pred Type) where + ppr = pprPredTy -- Not for arbitrary (Pred a), because the + -- (Outputable a) doesn't give precedence instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now @@ -480,106 +566,56 @@ instance Outputable name => OutputableBndr (IPName name) where ------------------ -- OK, here's the main printer -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - ppr_type :: Prec -> Type -> SDoc -ppr_type _ (TyVarTy tv) -- Note [Infix type variables] +ppr_type _ (TyVarTy tv) -- Note [Infix type variables] | isSymOcc (getOccName tv) = parens (ppr tv) | otherwise = ppr tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ - ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred) -ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys + ifPprDebug (ptext (sLit "<pred>")) <> (pprPredTy pred) +ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 -ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty +ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty ppr_type p (FunTy ty1 ty2) - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen p FunPrec $ - sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2) + = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2) where - ppr_fun_tail (FunTy ty1 ty2) - | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2 - ppr_fun_tail other_ty = [arrow <+> pprType other_ty] + -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + ppr_fun_tail (FunTy ty1 ty2) + | not (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 + ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] + is_pred (PredTy {}) = True is_pred _ = False ppr_forall_type :: Prec -> Type -> SDoc ppr_forall_type p ty = maybeParen p FunPrec $ - sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau] + sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau] where (tvs, rho) = split1 [] ty (ctxt, tau) = split2 [] rho - -- We need to be extra careful here as equality constraints will occur as - -- type variables with an equality kind. So, while collecting quantified - -- variables, we separate the coercion variables out and turn them into - -- equality predicates. - split1 tvs (ForAllTy tv ty) - | not (isCoVar tv) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) + split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty - split2 ps (ForAllTy tv ty) - | isCoVar tv = split2 (coVarPred tv : ps) ty split2 ps ty = (reverse ps, ty) -ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc -ppr_tc_app _ tc [] - = ppr_tc tc -ppr_tc_app _ tc [ty] - | tc `hasKey` listTyConKey = brackets (pprType ty) - | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]") - | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") - | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") - | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)") - | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") - | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") - -ppr_tc_app p tc tys - | isTupleTyCon tc && tyConArity tc == length tys - = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) - | otherwise - = ppr_type_app p (getName tc) tys - -ppr_type_app :: Prec -> Name -> [Type] -> SDoc --- Used for classes as well as types; that's why it's separate from ppr_tc_app -ppr_type_app p tc tys - | is_sym_occ -- Print infix if possible - , [ty1,ty2] <- tys -- We know nothing of precedence though - = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, - pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2]) - | otherwise - = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc)) - 2 (sep (map pprParendType tys))) - where - is_sym_occ = isSymOcc (getOccName tc) - -ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc -ppr_tc tc - = pp_nt_debug <> ppr tc - where - pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc - then ptext (sLit "<recnt>") - else ptext (sLit "<nt>")) - | otherwise = empty - ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) - where - kind = tyVarKind tv +pprTvBndr tv + | isLiftedTypeKind kind = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) + where + kind = tyVarKind tv \end{code} Note [Infix type variables] @@ -600,6 +636,59 @@ remember to parenthesise the operator, thus See Trac #2766. +\begin{code} +pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc +pprTcApp _ _ tc [] -- No brackets for SymOcc + = pp_nt_debug <> ppr tc + where + pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc + then ptext (sLit "<recnt>") + else ptext (sLit "<nt>")) + | otherwise = empty + +pprTcApp _ pp tc [ty] + | tc `hasKey` listTyConKey = brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]") + | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") + | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") + | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)") + | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") + | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") + +pprTcApp p pp tc tys + | isTupleTyCon tc && tyConArity tc == length tys + = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys))) + | otherwise + = pprTypeNameApp p pp (getName tc) tys + +---------------- +pprTypeApp :: NamedThing a => a -> [Type] -> SDoc +-- The first arg is the tycon, or sometimes class +-- Print infix if the tycon/class looks like an operator +pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys +pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc +-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp +pprTypeNameApp p pp tc tys + | is_sym_occ -- Print infix if possible + , [ty1,ty2] <- tys -- We know nothing of precedence though + = maybeParen p FunPrec $ + sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2] + | otherwise + = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys) + where + is_sym_occ = isSymOcc (getOccName tc) +---------------- +pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc +pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) + +---------------- +pprArrowChain :: Prec -> [SDoc] -> SDoc +-- pprArrowChain p [a,b,c] generates a -> b -> c +pprArrowChain _ [] = empty +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (arrow <+>) args)] +\end{code} diff --git a/compiler/types/TypeRep.lhs-boot b/compiler/types/TypeRep.lhs-boot index d519f62d2d..fe8fd59d1b 100644 --- a/compiler/types/TypeRep.lhs-boot +++ b/compiler/types/TypeRep.lhs-boot @@ -2,9 +2,10 @@ module TypeRep where data Type -data PredType +data Pred a data TyThing +type PredType = Pred Type type Kind = Type isCoercionKind :: Kind -> Bool diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 2acf71efa6..38507830ab 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -8,9 +8,11 @@ module Unify ( -- the "tc" prefix indicates that matching always -- respects newtypes (rather than looking through them) tcMatchTy, tcMatchTys, tcMatchTyX, - ruleMatchTyX, tcMatchPreds, MatchEnv(..), - - dataConCannotMatch, + ruleMatchTyX, tcMatchPreds, + + MatchEnv(..), matchList, + + typesCantMatch, -- Side-effect free unification tcUnifyTys, BindFlag(..), @@ -23,16 +25,17 @@ module Unify ( import Var import VarEnv import VarSet +import Kind import Type -import Coercion import TyCon -import DataCon import TypeRep import Outputable import ErrUtils import Util import Maybes import FastString + +import Control.Monad (guard) \end{code} @@ -67,9 +70,11 @@ Matching is much tricker than you might think. \begin{code} data MatchEnv - = ME { me_tmpls :: VarSet -- Template tyvars + = ME { me_tmpls :: VarSet -- Template variables , me_env :: RnEnv2 -- Renaming envt for nested foralls - } -- In-scope set includes template tyvars + } -- In-scope set includes template variables + -- Nota Bene: MatchEnv isn't specific to Types. It is used + -- for matching terms and coercions as well as types tcMatchTy :: TyVarSet -- Template tyvars -> Type -- Template @@ -121,7 +126,7 @@ tcMatchPreds -> [PredType] -> [PredType] -> Maybe TvSubstEnv tcMatchPreds tmpls ps1 ps2 - = match_list (match_pred menv) emptyTvSubstEnv ps1 ps2 + = matchList (match_pred menv) emptyTvSubstEnv ps1 ps2 where menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars } in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2) @@ -155,9 +160,8 @@ match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2 match menv subst (TyVarTy tv1) ty2 | Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound - = if tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2 + = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2 -- ty1 has no locally-bound variables, hence nukeRnEnvL - -- Note tcEqType...we are doing source-type matching here then Just subst else Nothing -- ty2 doesn't match @@ -201,14 +205,8 @@ match _ _ _ _ match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv -- Match the kind of the template tyvar with the kind of Type -- Note [Matching kinds] -match_kind menv subst tv ty - | isCoVar tv = do { let (ty1,ty2) = coVarKind tv - (ty3,ty4) = coercionKind ty - ; subst1 <- match menv subst ty1 ty3 - ; match menv subst1 ty2 ty4 } - | otherwise = if typeKind ty `isSubKind` tyVarKind tv - then Just subst - else Nothing +match_kind _ subst tv ty + = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst -- Note [Matching kinds] -- ~~~~~~~~~~~~~~~~~~~~~ @@ -226,15 +224,15 @@ match_kind menv subst tv ty -------------- match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv -match_tys menv subst tys1 tys2 = match_list (match menv) subst tys1 tys2 +match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2 -------------- -match_list :: (TvSubstEnv -> a -> a -> Maybe TvSubstEnv) - -> TvSubstEnv -> [a] -> [a] -> Maybe TvSubstEnv -match_list _ subst [] [] = Just subst -match_list fn subst (ty1:tys1) (ty2:tys2) = do { subst' <- fn subst ty1 ty2 - ; match_list fn subst' tys1 tys2 } -match_list _ _ _ _ = Nothing +matchList :: (env -> a -> b -> Maybe env) + -> env -> [a] -> [b] -> Maybe env +matchList _ subst [] [] = Just subst +matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b + ; matchList fn subst' as bs } +matchList _ _ _ _ = Nothing -------------- match_pred :: MatchEnv -> TvSubstEnv -> PredType -> PredType -> Maybe TvSubstEnv @@ -318,26 +316,10 @@ anything, type functions (incl newtypes) match anything, and only distinct data types fail to match. We can elaborate later. \begin{code} -dataConCannotMatch :: [Type] -> DataCon -> Bool --- Returns True iff the data con *definitely cannot* match a --- scrutinee of type (T tys) --- where T is the type constructor for the data con --- -dataConCannotMatch tys con - | null eq_spec = False -- Common - | all isTyVarTy tys = False -- Also common - | otherwise - = cant_match_s (map (substTyVar subst . fst) eq_spec) - (map snd eq_spec) +typesCantMatch :: [Type] -> [Type] -> Bool +typesCantMatch tys1 tys2 = ASSERT( equalLength tys1 tys2 ) + or (zipWith cant_match tys1 tys2) where - dc_tvs = dataConUnivTyVars con - eq_spec = dataConEqSpec con - subst = zipTopTvSubst dc_tvs tys - - cant_match_s :: [Type] -> [Type] -> Bool - cant_match_s tys1 tys2 = ASSERT( equalLength tys1 tys2 ) - or (zipWith cant_match tys1 tys2) - cant_match :: Type -> Type -> Bool cant_match t1 t2 | Just t1' <- coreView t1 = cant_match t1' t2 @@ -348,7 +330,7 @@ dataConCannotMatch tys con cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2) | isDataTyCon tc1 && isDataTyCon tc2 - = tc1 /= tc2 || cant_match_s tys1 tys2 + = tc1 /= tc2 || typesCantMatch tys1 tys2 cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc @@ -370,7 +352,6 @@ dataConCannotMatch tys con \end{code} - %************************************************************************ %* * Unification @@ -415,7 +396,7 @@ niFixTvSubst env = f env | otherwise = subst where range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet e - subst = mkTvSubst (mkInScopeSet range_tvs) e + subst = mkTvSubst (mkInScopeSet range_tvs) e not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs in_domain tv = tv `elemVarEnv` e diff --git a/compiler/utils/Pair.lhs b/compiler/utils/Pair.lhs new file mode 100644 index 0000000000..eb594af45f --- /dev/null +++ b/compiler/utils/Pair.lhs @@ -0,0 +1,47 @@ +
+A simple homogeneous pair type with useful Functor, Applicative, and
+Traversable instances.
+
+\begin{code}
+module Pair ( Pair(..), unPair, toPair, swap ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import Data.Monoid
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+data Pair a = Pair { pFst :: a, pSnd :: a }
+-- Note that Pair is a *unary* type constructor
+-- whereas (,) is binary
+
+-- The important thing about Pair is that it has a *homogenous*
+-- Functor instance, so you can easily apply the same function
+-- to both components
+instance Functor Pair where
+ fmap f (Pair x y) = Pair (f x) (f y)
+
+instance Applicative Pair where
+ pure x = Pair x x
+ (Pair f g) <*> (Pair x y) = Pair (f x) (g y)
+
+instance Foldable Pair where
+ foldMap f (Pair x y) = f x `mappend` f y
+
+instance Traversable Pair where
+ traverse f (Pair x y) = Pair <$> f x <*> f y
+
+instance Outputable a => Outputable (Pair a) where
+ ppr (Pair a b) = ppr a <+> char '~' <+> ppr b
+
+unPair :: Pair a -> (a,a)
+unPair (Pair x y) = (x,y)
+
+toPair :: (a,a) -> Pair a
+toPair (x,y) = Pair x y
+
+swap :: Pair a -> Pair a
+swap (Pair x y) = Pair y x
+\end{code}
\ No newline at end of file diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index ca6766ad29..4994e3f165 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -19,7 +19,6 @@ import PprCore import CoreSyn import CoreMonad ( CoreM, getHscEnv ) import Type -import Var import Id import OccName import DynFlags @@ -190,7 +189,7 @@ vectTopBinder var inline expr ; case vectDecl of Nothing -> return () Just (vdty, _) - | coreEqType vty vdty -> return () + | eqType vty vdty -> return () | otherwise -> cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $ (text "Expected type" <+> ppr vty) diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index 69ae84ff9d..165dbdaad3 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -33,7 +33,6 @@ import TysWiredIn import Type import TyCon import DataCon -import Var import Outputable import Data.Array diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 94de62aa72..ecb8a98afa 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -24,7 +24,6 @@ import CoreSyn import Type import Name import Module -import Var import Id import FastString import Outputable diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index dbdf6e1c8d..4676e182a9 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -234,7 +234,8 @@ vectScalarFun forceScalar recFns expr scalars' = scalars `extendVarSet` var is_scalar scalars (Cast e _coe) = is_scalar scalars e is_scalar scalars (Note _ e ) = is_scalar scalars e - is_scalar _scalars (Type _) = True + is_scalar _scalars (Type {}) = True + is_scalar _scalars (Coercion {}) = True -- Result: (<is this binding group scalar>, scalars ++ variables bound in this group) is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var) diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 84844101a3..4910464709 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -27,7 +27,6 @@ import FamInstEnv import OccName import Id import MkId -import Var import NameEnv import Unique diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs index 1556626690..c30bfed6ed 100644 --- a/compiler/vectorise/Vectorise/Type/PRepr.hs +++ b/compiler/vectorise/Vectorise/Type/PRepr.hs @@ -15,6 +15,7 @@ import CoreUtils import MkCore ( mkWildCase ) import TyCon import Type +import Kind import BuildTyCl import OccName import Coercion @@ -180,9 +181,9 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc r pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion pdata_co - . mkSymCoercion - $ mkTyConApp repr_co ty_args + co = mkAppCo pdata_co + . mkSymCo + $ mkAxInstCo repr_co ty_args scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) @@ -262,8 +263,8 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc r pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion pdata_co - $ mkTyConApp repr_co var_tys + co = mkAppCo pdata_co + $ mkAxInstCo repr_co var_tys scrut = mkCoerce co (Var arg) diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index 8cc2bec519..a6d9b2a4fd 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -10,7 +10,6 @@ import Vectorise.Builtins import TypeRep import Type import TyCon -import Var import Outputable import Control.Monad import Data.List diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs index 1a099e3174..c7020ea1ae 100644 --- a/compiler/vectorise/Vectorise/Utils.hs +++ b/compiler/vectorise/Vectorise/Utils.hs @@ -33,7 +33,6 @@ import Vectorise.Builtins import CoreSyn import CoreUtils import Type -import Var import Control.Monad @@ -47,7 +46,7 @@ collectAnnTypeArgs expr = go expr [] collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) collectAnnTypeBinders expr = go [] expr where - go bs (_, AnnLam b e) | isTyCoVar b = go (b:bs) e + go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e go bs e = (reverse bs, e) collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 0ffaa60d94..d41be1e87a 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -133,7 +133,7 @@ mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion mkBuiltinCo get_tc = do tc <- builtin get_tc - return $ mkTyConApp tc [] + return $ mkTyConAppCo tc [] mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type]) diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 152c51de1b..d784984f21 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -17,7 +17,6 @@ import Vectorise.Utils.Hoisting import CoreSyn import Type -import Var import MkCore import CoreUtils import TyCon diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs index 12b1b6fe4f..d0785e5148 100644 --- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs +++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs @@ -20,7 +20,6 @@ import CoreSyn import CoreUtils import CoreUnfold import Type -import Var import Id import BasicTypes( Arity ) import FastString diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 329cb6368d..9c7af44ca9 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -31,7 +31,6 @@ import Control.Monad paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) where - go ty k | Just k' <- kindView k = go ty k' go ty (FunTy k1 k2) = do tv <- newTyVar (fsLit "a") k1 @@ -136,9 +135,9 @@ prDictOfPReprInstTyCon ty prepr_tc prepr_args dict <- prDictOfReprType' rhs pr_co <- mkBuiltinCo prTyCon let Just arg_co = tyConFamilyCoercion_maybe prepr_tc - let co = mkAppCoercion pr_co - $ mkSymCoercion - $ mkTyConApp arg_co prepr_args + let co = mkAppCo pr_co + $ mkSymCo + $ mkAxInstCo arg_co prepr_args return $ mkCoerce co dict | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty) diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs index 8856afd832..a27afeaf99 100644 --- a/compiler/vectorise/Vectorise/Utils/Poly.hs +++ b/compiler/vectorise/Vectorise/Utils/Poly.hs @@ -11,7 +11,6 @@ import Vectorise.Monad import Vectorise.Utils.PADict import CoreSyn import Type -import Var import FastString import Control.Monad diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs index f32cf78088..9c81d30118 100644 --- a/compiler/vectorise/Vectorise/Var.hs +++ b/compiler/vectorise/Vectorise/Var.hs @@ -17,7 +17,6 @@ import Vectorise.Vect import Vectorise.Type.Type import CoreSyn import Type -import Var import VarEnv import Literal import Id |