From: Jose Pedro Magalhaes Date: Thu, 12 May 2011 11:26:03 +0000 (+0200) Subject: Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1b381af863d64aaa0a4dd9c816170c58e6131a9e;hp=c25b934ef544fa3eba0a9f9da41b363c470156cb Merge branch 'master' of darcs.haskell.org/ghc into ghc-generics Resolved conflicts: compiler/typecheck/TcTyClsDecls.lhs --- diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 5a62326..312ae94 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 $ (dataConTheta 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,25 @@ 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 +-- NB: look at *all* equality constraints, not only those +-- in dataConEqSpec; see Trac #5168 +dataConCannotMatch tys con + | null theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise + = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2) + | EqPred ty1 ty2 <- theta ] + where + dc_tvs = dataConUnivTyVars con + theta = dataConTheta con + subst = zipTopTvSubst dc_tvs tys +\end{code} + %************************************************************************ %* * \subsection{Splitting products} diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index fd65fe4..5ac2612 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 ec1f122..c106f53 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 4195156..257e1c6 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 a251734..c691f62 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 + other_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 other_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 @@ -305,8 +309,9 @@ mkDataConIds wrap_name wkr_name data_con `setStrictnessInfo` Just wrap_sig all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con - wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) - arg_dmds = map mk_dmd all_strict_marks + wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info) + wrap_stricts = dropList eq_spec all_strict_marks + wrap_arg_dmds = map mk_dmd wrap_stricts mk_dmd str | isBanged str = evalDmd | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the @@ -318,32 +323,26 @@ 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) wrap_stricts) i3 [] + -- The ev_args is the evidence arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper 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 +457,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 +473,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 +482,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} @@ -607,7 +602,7 @@ mkProductBox arg_ids ty mkReboxingAlt :: [Unique] -- Uniques for the new Ids -> DataCon - -> [Var] -- Source-level args, including existential dicts + -> [Var] -- Source-level args, *including* all evidence vars -> CoreExpr -- RHS -> CoreAlt @@ -628,15 +623,14 @@ 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') -- Term variable case go (arg:args) (str:stricts) us | isMarkedUnboxed str - = - let (binds, unpacked_args') = go args stricts us' + = let (binds, unpacked_args') = go args stricts us' (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg) in (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args') @@ -674,13 +668,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 +681,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 +692,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} @@ -853,7 +843,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} @@ -880,12 +870,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} @@ -903,7 +894,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 @@ -939,7 +930,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 @@ -1049,6 +1040,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 13810da..3c3ff7f 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,8 @@ 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 -- Used for kind variables during @@ -187,9 +178,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 @@ -268,11 +258,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 @@ -294,36 +282,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} %* * %************************************************************************ @@ -347,6 +305,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 @@ -392,20 +354,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 f275714..fca6256 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 6f03aad..e0ff52d 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 aad0037..6e97100 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/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 4dc7e32..0ee429d 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -689,15 +689,7 @@ machOps = listToUFM $ ( "gtu", MO_U_Gt ), ( "ltu", MO_U_Lt ), - ( "flt", MO_S_Lt ), - ( "fle", MO_S_Le ), - ( "feq", MO_Eq ), - ( "fne", MO_Ne ), - ( "fgt", MO_S_Gt ), - ( "fge", MO_S_Ge ), - ( "fneg", MO_S_Neg ), - - ( "and", MO_And ), + ( "and", MO_And ), ( "or", MO_Or ), ( "xor", MO_Xor ), ( "com", MO_Not ), @@ -705,7 +697,20 @@ machOps = listToUFM $ ( "shrl", MO_U_Shr ), ( "shra", MO_S_Shr ), - ( "lobits8", flip MO_UU_Conv W8 ), + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), ( "lobits16", flip MO_UU_Conv W16 ), ( "lobits32", flip MO_UU_Conv W32 ), ( "lobits64", flip MO_UU_Conv W64 ), diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 678c961..0fa1c38 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 af414f7..88509f9 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 @@ -510,12 +513,11 @@ freeVars (Let (Rec binds) body) body2 = freeVars body body_fvs = freeVarsOf body2 - freeVars (Cast expr co) - = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co) + = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) where expr2 = freeVars expr - cfvs = tyVarsOfType co + cfvs = tyCoVarsOfCo co freeVars (Note other_note expr) = (freeVarsOf expr2, AnnNote other_note expr2) @@ -523,5 +525,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 5cc82a2..031fd61 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,71 @@ lintKind kind ------------------- lintTyBndrKind :: OutTyVar -> LintM () -lintTyBndrKind tv - | isCoVar tv = lintCoVarKind tv - | otherwise = 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))]) +lintTyBndrKind tv = lintKind (tyVarKind tv) ------------------- -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' 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 (Refl ty) + = do { ty' <- lintInTy ty + ; return (ty', ty') } - | not (tyConHasKind tc) -- Just something bizarre like SuperKindTyCon - = badCo ty +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) } - | otherwise - = do { (ss,ts) <- mapAndUnzipM lintCoercion tys - ; check_co_app ty (tyConKind tc) ss - ; return (TyConApp tc ss, TyConApp tc ts) } - -lintCoercion' ty@(PredTy (ClassP cls tys)) - = do { (ss,ts) <- mapAndUnzipM lintCoercion tys - ; check_co_app ty (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) } +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 { 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 (ForAllCo v co) + = do { lintKind (tyVarKind v) + ; (s,t) <- addInScopeVar v (lintCoercion co) + ; return (ForAllTy v s, ForAllTy v t) } + +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 +693,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 +732,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 +767,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 +821,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 +887,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 +923,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 +936,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 +975,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 +1068,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 +1114,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 +1158,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 42379b4..0405716 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 a229b8c..047e6c3 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 " 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 - = ASSERT( isTyCoVar b ) + = ASSERT( isTyVar b ) Just (extendTvSubst subst b ty) - | isId b -- let x = e in + | Coercion co <- r + = ASSERT( isCoVar b ) + Just (extendCvSubst subst b co) + + | isId b -- let x = e in , 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 603b745..e754c6d 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 [] = () @@ -1170,9 +1191,11 @@ data AnnExpr' bndr annot | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnCast (AnnExpr bndr annot) Coercion + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the 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,12 +1222,13 @@ 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) deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co deAnnotate' (AnnNote note body) = Note note (deAnnotate body) deAnnotate' (AnnLet bind body) diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 582f873..377bfd8 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 d1b9fa0..5883013 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 70e1db7..a0a229f 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 07a1dfb..359419c 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 f1d4273..b6bc7d4 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 cb784e8..78df509 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,25 @@ 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 (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 041b842..e9452dc 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 3c4b25e..5303b0d 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 c5e0118..47fbf2e 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 37a3cf9..7b008e9 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 815c0d1..65cb815 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 @@ -597,17 +598,13 @@ decomposeRuleLhs bndrs lhs bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) 2 (ppr opt_lhs) - dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr - <+> ptext (sLit "is not bound in RULE lhs")) + dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr + , 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) - | otherwise = ptext (sLit "variable") <+> ppr bndr - - get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" - (tcSplitPredTy_maybe (idType b)) + | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) + | isEvVar bndr = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr)) + | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) \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 f46d99e..58ebc26 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 4088e44..e33b113 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 @@ -513,12 +513,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 @@ -529,21 +529,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 @@ -583,7 +583,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} @@ -787,7 +787,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)")) @@ -822,7 +822,7 @@ warnDiscardedDoBindings rhs rhs_ty -- but only if we didn't already warn due to Opt_WarnUnusedDoBind do { warn_wrong <- doptDs Opt_WarnWrongDoBind ; case tcSplitAppTy_maybe elt_ty of - Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty + Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty -> warnDs (wrongMonadBind rhs elt_ty) _ -> return () } } diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 4d0a148..b391b8f 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 3a97687..8b5c0a9 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) @@ -299,10 +296,11 @@ mkCoPrimCaseMatchResult var ty match_alts return (LitAlt lit, [], body) -mkCoAlgCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of exp - -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives - -> MatchResult +mkCoAlgCaseMatchResult + :: Id -- Scrutinee + -> Type -- Type of exp + -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult mkCoAlgCaseMatchResult var ty match_alts | isNewTyCon tycon -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) @@ -605,7 +603,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 15c5a55..1a044d3 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 03fa325..d84b901 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 18a06b0..f70a1b3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -416,6 +416,7 @@ Library Generics InstEnv TyCon + Kind Type TypeRep Unify @@ -442,6 +443,7 @@ Library MonadUtils OrdList Outputable + Pair Panic Pretty Serialized diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index b888747..426f4f2 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -31,7 +31,6 @@ import Type import DataCon import TyCon import Util -import Var import VarSet import TysPrim import DynFlags @@ -249,7 +248,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 @@ -833,8 +832,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple MASSERT(isAlgCase) 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 + where + real_bndrs = filterOut isTyVar bndrs my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) @@ -1197,6 +1196,9 @@ pushAtom d p e | Just e' <- bcView e = pushAtom d p e' +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable VoidArg + pushAtom d p (AnnVar v) | idCgRep v == VoidArg = return (nilOL, 0) @@ -1270,9 +1272,6 @@ pushAtom _ _ (AnnLit lit) -- Get the addr on the stack, untaggedly return (unitOL (PUSH_UBX (Right addr) 1), 1) -pushAtom d p (AnnCast e _) - = pushAtom d p (snd e) - pushAtom _ _ expr = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, expr))) @@ -1454,21 +1453,23 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) -- d) notes -- Type lambdas *can* occur in random expressions, -- 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 (AnnApp (_,e) (_, AnnType _)) = Just e -bcView _ = Nothing +bcView (AnnNote _ (_,e)) = Just e +bcView (AnnCast (_,e) _) = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e +bcView (AnnApp (_,e) (_, AnnType _)) = Just e +bcView _ = Nothing isVoidArgAtom :: AnnExpr' Var ann -> Bool isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e' isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidArgAtom _ = False +isVoidArgAtom (AnnCoercion {}) = True +isVoidArgAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = typePrimRep (idType v) -atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnVar v) = typePrimRep (idType v) +atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) atomRep :: AnnExpr' Id ann -> CgRep diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index b4068a7..b6c97c3 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -45,22 +45,19 @@ import TyCon import Name import VarEnv import Util -import ListSetOps import VarSet import TysPrim import PrelNames import TysWiredIn import DynFlags -import Outputable +import Outputable as Ppr import FastString --- import Panic - import Constants ( wORD_SIZE ) - import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IO ( IO(..) ) +import StaticFlags( opt_PprStyle_Debug ) import Control.Monad import Data.Maybe import Data.Array.Base @@ -186,7 +183,7 @@ getClosureData a = elems = fromIntegral (BCI.ptrs itbl) ptrsList = Array 0 (elems - 1) elems ptrs nptrs_data = [W# (indexWordArray# nptrs i) - | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ] + | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ] ASSERT(elems >= 0) return () ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) @@ -346,10 +343,17 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt} = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) <+> hsep (map (ppr_term1 True) tt) -} -- TODO Printing infix constructors properly - | null tt = return$ ppr dc - | otherwise = do - tt_docs <- mapM (y app_prec) tt - return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs) + | null sub_terms_to_show + = return (ppr dc) + | otherwise + = do { tt_docs <- mapM (y app_prec) sub_terms_to_show + ; return $ cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] } + where + sub_terms_to_show -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + | opt_PprStyle_Debug = tt + | otherwise = dropList (dataConTheta dc) tt ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t ppr_termM y p RefWrap{wrapped_term=t} = do @@ -414,55 +418,70 @@ cPprTerm printers_ = go 0 where firstJustM [] = return Nothing -- Default set of custom printers. Note that the recursion knot is explicit -cPprTermBase :: Monad m => CustomTermPrinter m +cPprTermBase :: forall m. Monad m => CustomTermPrinter m cPprTermBase y = [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) . mapM (y (-1)) . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) - (\ p t -> doList p t) - , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a) - , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a) - , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a) - , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a) - , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a) + ppr_list + , ifTerm (isTyCon intTyCon . ty) ppr_int + , ifTerm (isTyCon charTyCon . ty) ppr_char + , ifTerm (isTyCon floatTyCon . ty) ppr_float + , ifTerm (isTyCon doubleTyCon . ty) ppr_double + , ifTerm (isIntegerTy . ty) ppr_integer ] - where ifTerm pred f prec t@Term{} - | pred t = Just `liftM` f prec t - ifTerm _ _ _ _ = return Nothing - - isTupleTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (isBoxedTupleTyCon tc) - - isTyCon a_tc ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (a_tc == tc) - - isIntegerTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (tyConName tc == integerTyConName) - - coerceShow f _p = return . text . show . f . unsafeCoerce# . val - - --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) - print_elems <- mapM (y cons_prec) elems - return$ if isConsLast - then cparen (p >= cons_prec) - . pprDeeperList fsep - . punctuate (space<>colon) - $ print_elems - else brackets (pprDeeperList fcat$ - punctuate comma print_elems) - - where getListTerms Term{subTerms=[h,t]} = h : getListTerms t - getListTerms Term{subTerms=[]} = [] - getListTerms t@Suspension{} = [t] - getListTerms t = pprPanic "getListTerms" (ppr t) - doList _ _ = panic "doList" + where + ifTerm :: (Term -> Bool) + -> (Precedence -> Term -> m SDoc) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm pred f prec t@Term{} + | pred t = Just `liftM` f prec t + ifTerm _ _ _ _ = return Nothing + + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (isBoxedTupleTyCon tc) + + isTyCon a_tc ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (a_tc == tc) + + isIntegerTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (tyConName tc == integerTyConName) + + ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer + :: Precedence -> Term -> m SDoc + ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) + ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') + ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v))) + ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v))) + ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v))) + + --Note pprinting of list terms is not lazy + ppr_list :: Precedence -> Term -> m SDoc + ppr_list p (Term{subTerms=[h,t]}) = do + let elems = h : getListTerms t + isConsLast = not(termType(last elems) `eqType` termType h) + is_string = all (isCharTy . ty) elems + + print_elems <- mapM (y cons_prec) elems + if is_string + then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) + else if isConsLast + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep + $ punctuate (space<>colon) print_elems + else return $ brackets + $ pprDeeperList fcat + $ punctuate comma print_elems + + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t + getListTerms Term{subTerms=[]} = [] + getListTerms t@Suspension{} = [t] + getListTerms t = pprPanic "getListTerms" (ppr t) + ppr_list _ _ = panic "doList" repPrim :: TyCon -> [Word] -> String @@ -566,6 +585,11 @@ liftTcM = id newVar :: Kind -> TR TcType newVar = liftTcM . newFlexiTyVarTy +instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst) +-- Instantiate fresh mutable type variables from some TyVars +-- This function preserves the print-name, which helps error messages +instTyVars = liftTcM . tcInstTyVars + type RttiInstantiation = [(TcTyVar, TyVar)] -- Associates the typechecker-world meta type variables -- (which are mutable and may be refined), to their @@ -658,7 +682,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Type obtained: " <> ppr (termType term)) return term where + go :: Int -> Type -> Type -> HValue -> TcM Term + -- [SPJ May 11] I don't understand the difference between my_ty and old_ty + go max_depth _ _ _ | seq max_depth False = undefined go 0 my_ty _old_ty a = do traceTR (text "Gave up reconstructing a term after" <> @@ -704,7 +731,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do traceTR (text "entering a constructor " <> if monomorphic then parens (text "already monomorphic: " <> ppr my_ty) - else Outputable.empty) + else Ppr.empty) Right dcname <- dataConInfoPtrToName (infoPtr clos) (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) case mb_dc of @@ -713,59 +740,34 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- In such case, we return a best approximation: -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. + traceTR (text "Nothing" <+> ppr dcname) let tag = showSDoc (ppr dcname) vars <- replicateM (length$ elems$ ptrs clos) - (newVar (liftedTypeKind)) + (newVar liftedTypeKind) subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i | (i, tv) <- zip [0..] vars] return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do - let subTtypes = matchSubTypes dc old_ty - subTermTvs <- mapMif (not . isMonomorphic) - (\t -> newVar (typeKind t)) - subTtypes - let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty - || isRefType ty) - (zip subTtypes subTermTvs) - (subTtypesP, subTermTvsP ) = unzip subTermsP - (subTtypesNP, _subTermTvsNP) = unzip subTermsNP - - -- When we already have all the information, avoid solving - -- unnecessary constraints. Propagation of type information - -- to subterms is already being done via matching. - when (not monomorphic) $ do - let myType = mkFunTys subTermTvs my_ty - (signatureType,_) <- instScheme (mydataConType dc) - -- It is vital for newtype reconstruction that the unification step - -- is done right here, _before_ the subterms are RTTI reconstructed - addConstraint myType signatureType + traceTR (text "Just" <+> ppr dc) + subTtypes <- getDataConArgTys dc my_ty + let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes subTermsP <- sequence - [ appArr (go (pred max_depth) tv t) (ptrs clos) i - | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP] + [ appArr (go (pred max_depth) ty ty) (ptrs clos) i + | (i,ty) <- zip [0..] subTtypesP] let unboxeds = extractUnboxed subTtypesNP clos - subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds) + subTermsNP = zipWith Prim subTtypesNP unboxeds subTerms = reOrderTerms subTermsP subTermsNP subTtypes return (Term my_ty (Right dc) a subTerms) + -- The otherwise case: can be a Thunk,AP,PAP,etc. tipe_clos -> return (Suspension tipe_clos my_ty a Nothing) - matchSubTypes dc ty - | ty' <- repType ty -- look through newtypes - , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty' - , dc `elem` tyConDataCons tc - -- It is necessary to check that dc is actually a constructor for tycon tc, - -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp - -- has not removed it. In that case, we happily give up and don't match - = myDataConInstArgTys dc ty_args - | otherwise = dataConRepArgTys dc - -- put together pointed and nonpointed subterms in the -- correct order. reOrderTerms _ _ [] = [] reOrderTerms pointed unpointed (ty:tys) - | isLifted ty || isRefType ty - = ASSERT2(not(null pointed) + | isPtrType ty = ASSERT2(not(null pointed) , ptext (sLit "reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) let (t:tt) = pointed in t : reOrderTerms tt unpointed tys @@ -835,6 +837,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do -- returns unification tasks,since we are going to want a breadth-first search go :: Type -> HValue -> TR [(Type, HValue)] go my_ty a = do + traceTR (text "go" <+> ppr my_ty) clos <- trIO $ getClosureData a case tipe clos of Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO @@ -847,6 +850,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do return [(tv', contents)] Constr -> do Right dcname <- dataConInfoPtrToName (infoPtr clos) + traceTR (text "Constr1" <+> ppr dcname) (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) case mb_dc of Nothing-> do @@ -856,17 +860,10 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do return$ appArr (\e->(tv,e)) (ptrs clos) i Just dc -> do - subTtypes <- mapMif (not . isMonomorphic) - (\t -> newVar (typeKind t)) - (dataConRepArgTys dc) - - -- It is vital for newtype reconstruction that the unification step - -- is done right here, _before_ the subterms are RTTI reconstructed - let myType = mkFunTys subTtypes my_ty - (signatureType,_) <- instScheme (mydataConType dc) - addConstraint myType signatureType - return $ [ appArr (\e->(t,e)) (ptrs clos) i - | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)] + arg_tys <- getDataConArgTys dc my_ty + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + return $ [ appArr (\e-> (ty,e)) (ptrs clos) i + | (i,ty) <- zip [0..] (filter isPtrType arg_tys)] _ -> return [] -- Compute the difference between a base type and the type found by RTTI @@ -877,36 +874,36 @@ improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst improveRTTIType _ base_ty new_ty = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty] -myDataConInstArgTys :: DataCon -> [Type] -> [Type] -myDataConInstArgTys dc args - | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args - | otherwise = dataConRepArgTys dc - -mydataConType :: DataCon -> QuantifiedType --- ^ Custom version of DataCon.dataConUserType where we --- - remove the equality constraints --- - use the representation types for arguments, including dictionaries --- - keep the original result type -mydataConType dc - = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs - , mkFunTys arg_tys res_ty ) - where univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyVars dc - eq_spec = dataConEqSpec dc - arg_tys = [case a of - PredTy p -> predTypeRep p - _ -> a - | a <- dataConRepArgTys dc] - res_ty = dataConOrigResTy dc - -isRefType :: Type -> Bool -isRefType ty - | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc - | otherwise = False - where ty'= repType ty - -isRefTyCon :: TyCon -> Bool -isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon] +getDataConArgTys :: DataCon -> Type -> TR [Type] +-- Given the result type ty of a constructor application (D a b c :: ty) +-- return the types of the arguments. This is RTTI-land, so 'ty' might +-- not be fully known. Moreover, the arg types might involve existentials; +-- if so, make up fresh RTTI type variables for them +getDataConArgTys dc con_app_ty + = do { (_, ex_tys, _) <- instTyVars ex_tvs + ; let rep_con_app_ty = repType con_app_ty + ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of + Just (tc, ty_args) | dataConTyCon dc == tc + -> ASSERT( univ_tvs `equalLength` ty_args) + return ty_args + _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs + ; let res_ty = substTy subst (dataConOrigResTy dc) + ; addConstraint rep_con_app_ty res_ty + ; return ty_args } + -- It is necessary to check dataConTyCon dc == tc + -- because it may be the case that tc is a recursive + -- newtype and tcSplitTyConApp has not removed it. In + -- that case, we happily give up and don't match + ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys) + ; return (substTys subst (dataConRepArgTys dc)) } + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyVars dc + +isPtrType :: Type -> Bool +isPtrType ty = case typePrimRep ty of + PtrRep -> True + _ -> False -- Soundness checks -------------------- @@ -1103,7 +1100,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') | otherwise = do traceTR (text "(Upgrade) upgraded " <> ppr ty <> text " in presence of newtype evidence " <> ppr new_tycon) - vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon) + (_, vars, _) <- instTyVars (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon vars _ <- liftTcM (unifyType ty (repType ty')) -- assumes that reptype doesn't ^^^^ touch tyconApp args @@ -1183,12 +1180,6 @@ quantifyType :: Type -> QuantifiedType -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll. quantifyType ty = (varSetElems (tyVarsOfType ty), ty) -mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a] -mapMif pred f xx = sequence $ mapMif_ pred f xx - where - mapMif_ _ _ [] = [] - mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx - unlessM :: Monad m => m Bool -> m () -> m () unlessM condM acc = condM >>= \c -> unless c acc @@ -1205,24 +1196,10 @@ amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] where g (I# i#) = case indexArray# arr# i# of (# e #) -> f e - -isLifted :: Type -> Bool -isLifted = not . isUnLiftedType - extractUnboxed :: [Type] -> Closure -> [[Word]] extractUnboxed tt clos = go tt (nonPtrs clos) - where sizeofType t - | Just (tycon,_) <- tcSplitTyConApp_maybe t - = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon - | otherwise = pprPanic "Expected a TcTyCon" (ppr t) + where sizeofType t = primRepSizeW (typePrimRep t) go [] _ = [] go (t:tt) xx | (x, rest) <- splitAt (sizeofType t) xx = x : go tt rest - -sizeofTyCon :: TyCon -> Int -- in *words* -sizeofTyCon = primRepSizeW . tyConPrimRep - - -(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool -(f |.| g) x = f x || g x diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index dab2860..81b5f18 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 13b9d6e..7fb5f72 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 526f7eb..dfb3dd5 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, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, + coToHsWrapper, mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsComp, 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 993159b..c80628b 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 9522024..92d0f42 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -99,8 +99,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 } ------------------------------------------------------ @@ -126,23 +126,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 @@ -155,7 +147,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 dcf2177..49fded9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -227,12 +227,13 @@ data IfaceExpr = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] - | IfaceLet IfaceBinding IfaceExpr - | IfaceNote IfaceNote IfaceExpr + | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType @@ -588,6 +589,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) @@ -600,17 +602,17 @@ pprIfaceExpr add_par i@(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 noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, - pprIfaceExpr noParens rhs <+> char '}']) +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 noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) +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 '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, @@ -786,6 +788,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 @@ -828,16 +832,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 s +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - &&& freeNamesIfType ty where fn_alt (_con,_bs,r) = freeNamesIfExpr r @@ -863,6 +867,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 c97e16e..7817b42 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,39 @@ 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 (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 847e7c7..5c58a80 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 @@ -1386,14 +1386,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] @@ -1401,6 +1403,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 @@ -1565,6 +1569,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 @@ -1584,15 +1590,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 a4da138..7ac95b1 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 @@ -790,20 +790,56 @@ 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 +tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo" + +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} @@ -818,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 @@ -852,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 @@ -867,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) @@ -897,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 @@ -941,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} @@ -1216,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 488cf86..87bf391 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1985,14 +1985,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 @@ -2133,7 +2132,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 a9e652d..44ec3ff 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 11f1a8b..4d096d2 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 d859784..6d5344d 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -23,8 +23,8 @@ import DataCon import Id import IdInfo import TyCon +import Coercion( pprCoAxiom ) import TcType -import Var import Name import Outputable import FastString @@ -45,7 +45,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 +57,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 ax) = pprCoAxiom ax 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 +78,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 +95,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 ax) = pprCoAxiom ax pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc @@ -103,7 +105,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 +118,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 +127,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 +149,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 +162,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 +170,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 +186,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 +216,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 +239,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 +270,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 f23280b..b4296cb 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 8bf9453..3f2b32a 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 a678a9d..101780d 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1129,11 +1129,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 @@ -1167,9 +1168,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, @@ -1393,6 +1393,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 8f2d21f..93cc576 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 ac3a528..4b3492b 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 e0d23dd..5a80067 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} @@ -607,5 +592,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 0e653fe..80a47a4 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -457,7 +457,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 @@ -477,7 +477,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 3a20ac4..46058c4 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 ea87745..be90d7d 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 523431f..5bec8f0 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 b9f44c9..48daf78 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -126,14 +126,15 @@ fiExpr :: FloatingBinds -- Binds we're trying to drop -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result -fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) - -fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) - Type ty -fiExpr to_drop (_, AnnCast expr co) - = Cast (fiExpr to_drop expr) co -- Just float in past coercion - -fiExpr _ (_, AnnLit lit) = Lit lit +fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit +fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) +fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co) +fiExpr to_drop (_, AnnCast expr (fvs_co, co)) + = mkCoLets' (drop_here ++ co_drop) $ + Cast (fiExpr e_drop expr) co + where + [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop \end{code} Applications: we do float inside applications, mainly because we @@ -198,7 +199,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 2a51a21..e5db7d9 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 2b19062..fe1f758 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 7692b62..ba7d192 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,7 @@ 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]) | not (binder `usedIn` body_usage) -- It's not mentioned @@ -381,7 +382,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 +873,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 +909,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 +927,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 +1019,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 +1046,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 +1157,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 +1366,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 +1583,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 +1596,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 +1607,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 +1618,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 +1632,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 +1663,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 +1686,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 +1753,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 d398055..6118289 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 6871faa..21dca61 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) @@ -287,7 +288,7 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr) = do expr' <- lvlExpr ctxt_lvl env expr return (Note note expr') -lvlExpr ctxt_lvl env (_, AnnCast expr co) = do +lvlExpr ctxt_lvl env (_, AnnCast expr (_, co)) = do expr' <- lvlExpr ctxt_lvl env expr return (Cast expr' co) @@ -414,7 +415,7 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e) = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e ; return (Note n e') } -lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co) +lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e (_, co)) = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e ; return (Cast e' co) } @@ -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 d9eea39..677a1e9 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". @@ -273,12 +279,17 @@ setEnclosingCC env cc = env {seCC = cc} --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res - = env {seIdSubst = extendVarEnv subst var res} + = ASSERT2( isId var && not (isCoVar var), ppr var ) + env {seIdSubst = extendVarEnv subst var res} 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 +329,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 +514,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,7 +559,7 @@ 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) } | otherwise = do { let (env', id) = substIdBndr env bndr ; seqId id `seq` return (env', id) } @@ -586,9 +596,17 @@ simplRecBndrs env@(SimplEnv {}) ids ; seqIds ids1 `seq` return env1 } --------------- -substIdBndr :: SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) +substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr + +--------------- +substNonCoVarIdBndr + :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) -- Clone Id if necessary, substitute its type -- Return an Id with its -- * Type substituted @@ -606,10 +624,10 @@ substIdBndr :: SimplEnv -- Similar to CoreSubst.substIdBndr, except that -- the type of id_subst differs -- all fragile info is zapped - -substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) - old_id - = (env { seInScope = in_scope `extendInScopeSet` new_id, +substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id + = ASSERT2( not (isCoVar old_id), ppr old_id ) + (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id) where id1 = uniqAway in_scope old_id @@ -714,6 +732,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 +746,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 +766,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 7e9a010..7d5d764 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} @@ -99,6 +99,7 @@ data SimplCont | CoerceIt -- C `cast` co OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion SimplCont | ApplyTo -- C arg @@ -208,6 +209,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 +218,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 +239,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 @@ -784,6 +789,11 @@ Don't inline top-level Ids that are bottoming, even if they are used just once, because FloatOut has gone to some trouble to extract them out. Inlining them won't make the program run faster! +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and have a separate +substitution, so don't inline them via the IdSubst! + \begin{code} preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool preInlineUnconditionally env top_lvl bndr rhs @@ -791,6 +801,7 @@ preInlineUnconditionally env top_lvl bndr rhs | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] | opt_SimplNoPreInlining = False + | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally] | otherwise = case idOccInfo bndr of IAmDead -> True -- Happens in ((\x.1) v) OneOcc in_lam True int_cxt -> try_once in_lam int_cxt @@ -888,6 +899,7 @@ story for now. postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -- The binder (an InId would be fine too) + -- (*not* a CoVar) -> OccInfo -- From the InId -> OutExpr -> Unfolding @@ -1032,9 +1044,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 +1060,7 @@ mkLam _env bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | otherwise + | otherwise = return (mkLams bndrs body) \end{code} @@ -1091,9 +1103,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 +1345,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 +1557,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 db84c90..b187897 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} @@ -369,8 +369,11 @@ simplNonRecX :: SimplEnv -> SimplM 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 + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + | 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 +441,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) } @@ -626,6 +629,12 @@ completeBind :: SimplEnv -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (extendCvSubst env old_bndr co) + _ -> return (addNonRec env new_bndr new_rhs) + + | otherwise = ASSERT( isId new_bndr ) do { let old_info = idInfo old_bndr old_unf = unfoldingInfo old_info @@ -641,9 +650,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding -- Inline and discard the binding then do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" - -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $ - return (extendIdSubst env old_bndr (DoneEx final_rhs)) } + ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding else @@ -658,7 +665,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 @@ -870,18 +877,21 @@ simplExprF :: SimplEnv -> InExpr -> SimplCont simplExprF env e cont = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ - simplExprF' env e cont + simplExprF1 env e cont -simplExprF' :: SimplEnv -> InExpr -> SimplCont +simplExprF1 :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVarF 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 $ +simplExprF1 env (Var v) cont = simplIdF env v cont +simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF1 env (Note n expr) cont = simplNote env n expr cont +simplExprF1 env (Cast body co) cont = simplCast env body co cont +simplExprF1 env (Coercion co) cont = simplCoercionF env co cont +simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) + rebuild env (Type (substTy env ty)) cont +simplExprF1 env (App fun arg) cont = simplExprF env fun $ ApplyTo NoDup arg env cont -simplExprF' env expr@(Lam _ _) cont +simplExprF1 env expr@(Lam {}) cont = simplLam env zapped_bndrs body cont -- The main issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 @@ -898,17 +908,12 @@ 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 -simplExprF' env (Type ty) cont - = ASSERT( contIsRhsOrArg cont ) - do { ty' <- simplCoercion env ty - ; rebuild env (Type ty') cont } + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b -simplExprF' env (Case scrut bndr _ alts) cont +simplExprF1 env (Case scrut bndr _ alts) cont | sm_case_case (getMode env) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -920,7 +925,7 @@ simplExprF' env (Case scrut bndr _ alts) cont (Select NoDup bndr alts env mkBoringStop) ; rebuild env case_expr' cont } -simplExprF' env (Let (Rec pairs) body) cont +simplExprF1 env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -928,7 +933,7 @@ simplExprF' env (Let (Rec pairs) body) cont ; env'' <- simplRecBind env' NotTopLevel pairs ; simplExprF env'' body cont } -simplExprF' env (Let (NonRec bndr rhs) body) cont +simplExprF1 env (Let (NonRec bndr rhs) body) cont = simplNonRecE env bndr (rhs, env) ([], body) cont --------------------------------- @@ -941,13 +946,30 @@ 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 +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +-- We are simplifying a term of form (Coercion co) +-- Simplify the InCoercion, and then try to combine with the +-- context, to implememt the rule +-- (Coercion co) |> g +-- = Coercion (syn (nth 0 g) ; co ; nth 1 g) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; simpl_co co' cont } + where + simpl_co co (CoerceIt g cont) + = simpl_co new_co cont + where + new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1 + [g0, g1] = decomposeCo 2 g + + simpl_co co cont + = seqCo co `seq` rebuild env (Coercion co) cont + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = seqType new_co `seq` return new_co - where - new_co = optCoercion (getTvSubst env) co + = let opt_co = optCoercion (getCvSubst env) co + in opt_co `seq` return opt_co \end{code} @@ -964,7 +986,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) rebuild env expr cont = case cont of Stop {} -> return (env, expr) - CoerceIt co cont -> rebuild env (mkCoerce co expr) cont + CoerceIt co cont -> rebuild env (Cast expr co) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr @@ -991,11 +1013,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 +1027,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 +1081,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,7 +1154,7 @@ 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 } @@ -1130,12 +1164,12 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - | isStrictId bndr + | isStrictId bndr -- Includes coercions = do { simplExprF (rhs_se `setFloats` env) rhs (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 +1211,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 +1300,14 @@ 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@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) @@ -1280,7 +1315,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 +1806,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 +1869,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 +1968,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 +2186,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 3205542..f9d02e5 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 4fa4204..5fc0226 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 415378a..c192b3f 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 2059937..df8fabe 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 @@ -312,8 +312,9 @@ on these components, but it in turn is not scrutinised as the basis for any decisions. Hence no black holes. \begin{code} -coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet) -coreToStgExpr (Var v) = coreToStgApp Nothing v [] +coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] +coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] coreToStgExpr expr@(App _ _) = coreToStgApp Nothing f args @@ -572,6 +573,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 +1129,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 3bce281..dd026eb 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 192d06f..afa722f 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 5cf5e92..ac10b1b 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 e7d0edf..391c07c 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) => -Which really means forall (co:a~b). -Because the name of the coercion variable, 'co', isn't mentioned in , -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 , 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 , 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 45584d9..c41806a 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 bbdf21b..5474cfa 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 cfbdf35..7ce5fc1 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -43,17 +43,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} @@ -181,8 +181,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)) @@ -239,7 +239,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 @@ -269,7 +269,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 33e9081..8462403 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -844,7 +844,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 59cc736..44cff5e 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 adf72cf..52ce0c2 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1356,7 +1356,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 the_pred tyvars deriv_rhs @@ -1487,14 +1487,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 b5884a7..96dc261 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -626,7 +626,7 @@ 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 + 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 +640,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 645c43a..0d0a9f8 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -16,14 +16,12 @@ import TcSMonad import TcType import TypeRep import Type( isTyVarTy ) - import Inst import InstEnv - import TyCon import Name import NameEnv -import Id ( idType ) +import Id ( idType, evVarPred ) import Var import VarSet import VarEnv @@ -223,7 +221,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) @@ -300,8 +298,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 @@ -574,7 +572,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) @@ -583,7 +581,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 79b097e..ee6a34a 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -288,8 +288,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) @@ -297,8 +297,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 @@ -308,8 +308,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 @@ -320,15 +320,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) @@ -347,19 +347,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} @@ -422,7 +422,7 @@ tcExpr (HsDo do_or_lc stmts _) 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), @@ -469,7 +469,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} @@ -605,7 +605,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) @@ -643,10 +643,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 @@ -661,11 +661,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 @@ -705,7 +705,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 @@ -713,7 +713,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 @@ -722,7 +722,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 @@ -732,7 +732,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 @@ -741,7 +741,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 @@ -751,7 +751,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 _ _) _ @@ -829,8 +829,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) } @@ -852,7 +852,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) } @@ -901,7 +901,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 @@ -1012,7 +1012,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} @@ -1136,7 +1136,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") ] @@ -1144,18 +1144,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 2826dcb..ad640ef 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 @@ -1837,7 +1836,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 d179a0e..cd2cadf 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} @@ -675,7 +677,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') } @@ -1008,7 +1010,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} @@ -1038,10 +1039,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) @@ -1116,4 +1117,27 @@ 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 (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} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 182d1fc..65f16c5 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -848,7 +848,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', @@ -860,8 +860,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 @@ -884,20 +883,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 @@ -908,7 +907,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 1462179..3a7ecc7 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 @@ -1047,13 +1225,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) @@ -1077,7 +1254,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 @@ -1267,4 +1445,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 fb6929a..fd66d0a 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 @@ -1056,7 +1053,7 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) Wanted {} -> do { setIPBind (cc_id workItem) $ - EvCast id1 (mkSymCoercion (mkCoVarCoercion co_var)) + EvCast id1 (mkSymCo (mkCoVarCo co_var)) ; mkIRStopK "IP/IP interaction (solved)" cans } } @@ -1097,23 +1094,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 @@ -1144,13 +1141,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 @@ -1161,11 +1158,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 @@ -1176,20 +1173,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 () @@ -1210,20 +1208,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: @@ -1236,9 +1234,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' } @@ -1246,9 +1244,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' } @@ -1256,12 +1254,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 () @@ -1272,8 +1270,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 @@ -1741,7 +1739,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, @@ -1790,15 +1788,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 1d163aa..531ee44 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 @@ -300,10 +297,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 @@ -342,9 +335,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; @@ -750,13 +740,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 @@ -779,16 +768,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} @@ -1159,7 +1138,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 () @@ -1281,7 +1260,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} @@ -1348,14 +1327,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 @@ -1503,7 +1482,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 48fdf77..29890a2 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -30,7 +30,7 @@ import TysWiredIn import Id import TyCon import TysPrim -import Coercion ( isIdentityCoI, mkSymCoI ) +import Coercion ( isReflCo, mkSymCo ) import Outputable import Util import SrcLoc @@ -147,7 +147,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} %************************************************************************ @@ -248,13 +248,13 @@ tcDoStmts ListComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; let list_ty = mkListTy elt_ty ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty - ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) } + ; return $ mkHsWrapCo coi (HsDo ListComp stmts' list_ty) } tcDoStmts PArrComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ; let parr_ty = mkPArrTy elt_ty ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty - ; return $ mkHsWrapCoI coi (HsDo PArrComp stmts' parr_ty) } + ; return $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) } tcDoStmts DoExpr stmts res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty @@ -730,7 +730,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi -- so for now we just check that it's the identity check_same actual expected = do { coi <- unifyType actual expected - ; unless (isIdentityCoI coi) $ + ; unless (isReflCo coi) $ failWithMisMatch [UnifyOrigin { uo_expected = expected , uo_actual = actual }] } diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index ebd84e2..8304a22 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -148,7 +148,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] @@ -192,7 +192,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) -- @@ -204,11 +204,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 @@ -372,7 +372,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 @@ -422,7 +422,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 $ @@ -447,7 +447,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 @@ -507,7 +507,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) } ------------------------ @@ -542,19 +542,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] @@ -653,7 +653,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] @@ -675,9 +675,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' @@ -692,8 +691,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) + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta' no_equalities = not (any isEqPred theta') @@ -722,21 +720,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 @@ -745,7 +743,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 @@ -760,10 +758,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 f3e8691..011b024 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 @@ -645,7 +644,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 +668,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 +685,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 +694,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 +704,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 +727,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 +736,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 +760,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 @@ -1327,16 +1316,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) } ; @@ -1622,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 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] where fi_tycons = map famInstTyCon fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] @@ -1654,13 +1643,8 @@ 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_rules :: [CoreRule] -> SDoc ppr_rules [] = empty diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index bd48872..7e7f117 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 @@ -892,6 +891,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 e511532..7d761eb 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 b2c1dac..3925c6d 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 5f4522c..07e61a2 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 @@ -206,9 +208,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} @@ -676,7 +678,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 cf41372..57ff636 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 @@ -986,7 +988,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 f68239e..d6517a6 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 cb16097..43a0da7 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" @@ -140,188 +141,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 - 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 %* * %************************************************************************ @@ -666,34 +485,17 @@ tcTyClDecl1 _parent calc_isrec ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt ; 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 @@ -750,6 +552,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] @@ -1102,14 +927,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 () @@ -1503,39 +1328,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 a9ea11a..cb61726 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 d9166d1..a825d23 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 @@ -216,6 +217,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 +265,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. @@ -390,7 +393,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") @@ -426,19 +429,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 @@ -527,6 +524,40 @@ 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 (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} %************************************************************************ %* * @@ -670,22 +701,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 @@ -835,13 +863,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) @@ -884,60 +911,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} @@ -947,7 +920,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 = [] @@ -967,53 +940,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. ) - -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} - %************************************************************************ %* * @@ -1035,17 +961,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} @@ -1107,14 +1026,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 @@ -1124,61 +1038,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. @@ -1211,6 +1070,26 @@ 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 (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} @@ -1225,7 +1104,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 @@ -1236,7 +1115,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) @@ -1244,7 +1123,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 e229b8b..572ad44 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 244f0cb..e7ad418 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 faab463..7df5b8e 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,454 @@ 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, pprCoAxiom, + -- * 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 Class ( classTyCon ) 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 TysPrim ( eqPredPrimTyCon ) +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 + + -- 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. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + %************************************************************************ %* * - 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 (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 (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 (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 = 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 _ (CoVarCo cv) + | isSymOcc (getOccName cv) = parens (ppr cv) + | otherwise = ppr cv + +ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos --- | A 'CoercionKind' is always of form @ty1 ~ ty2@ and indicates the --- types that a 'Coercion' will work on. -type CoercionKind = Kind ------------------------------- +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 --- | This breaks a 'Coercion' with 'CoercionKind' @T A B C ~ T D E F@ into +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, ppr_co TopPrec rho] + where + (tvs, rho) = split1 [] ty + split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) +\end{code} + +\begin{code} +pprCoAxiom :: CoAxiom -> SDoc +pprCoAxiom ax + = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax) + , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ] +\end{code} + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ + +\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) + | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc + , Just (cos', co') <- snocView cos + = Just (mkTyConAppCo tc cos', co') -- Never create unsaturated type family apps! + -- 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) +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 +473,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 +489,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 +504,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 +-- See Note [Predicate coercions] +mkPredCo (EqPred co1 co2) = mkTyConAppCo eqPredPrimTyCon [co1,co2] +mkPredCo (ClassP cls cos) = mkTyConAppCo (classTyCon cls) cos +mkPredCo (IParam _ co) = 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) - - + -> 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} - -%************************************************************************ -%* * - 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 -\end{code} - - %************************************************************************ %* * Newtypes @@ -561,17 +662,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 +686,425 @@ 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 (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} -liftCoI :: (Type -> Type) -> CoercionI -> CoercionI -liftCoI f (IdCo ty) = IdCo (f ty) -liftCoI f (ACo ty) = ACo (f ty) +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. -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)) +This also why we need a full CvSubst when doing lifting substitutions. -liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI -liftCoIs f cois = go_id [] cois +\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 - 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) + 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 --- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI' -mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI -mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn) + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 --- | 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 (AppTy ty1 ty2) co + | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = do { subst' <- ty_co_match menv subst ty1 co1 + ; ty_co_match menv subst' ty2 co2 } -mkCoPredCoI :: CoercionI -> CoercionI -> CoercionI -> CoercionI -mkCoPredCoI coi1 coi2 coi3 = mkFunTyCoI (mkEqPredCoI coi1 coi2) coi3 +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos) + | tc1 == tc2 = ty_co_matches menv subst tys cos +ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos) + | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos +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 (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 --- 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 +-- 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 +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 co@(InstCo aco ty) | Just ks <- splitForAllTy_maybe `traverse` coercionKind aco + = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks + | otherwise = 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 93a67a7..894da34 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 6ce932b..f1c9347 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 _ _ = [] @@ -386,7 +386,7 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' irs2' -- Don't discard anything! -- We could discard equal types but it's an overkill to call - -- tcEqType again, since we know for sure that /at least one/ + -- eqType again, since we know for sure that /at least one/ -- equation in there is useful) qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 07f68f7..7a2a65e 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 0000000..23787d2 --- /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 26f3295..eef1ccf 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -1,456 +1,372 @@ -% -% (c) The University of Glasgow 2006 -% - -\begin{code} -{-# OPTIONS_GHC -w #-} -module OptCoercion ( - optCoercion - ) where - -#include "HsVersions.h" - -import Unify ( tcMatchTy ) -import Coercion -import Type -import TypeRep -import TyCon -import Var -import VarSet -import VarEnv -import PrelNames -import StaticFlags ( opt_NoOptCoercion ) -import Util -import Outputable -\end{code} - -%************************************************************************ -%* * - Optimising coercions -%* * -%************************************************************************ - -Note [Subtle shadowing in coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose we optimising a coercion - optCoercion (forall (co_X5:t1~t2). ...co_B1...) -The co_X5 is a wild-card; the bound variable of a coercion for-all -should never appear in the body of the forall. Indeed we often -write it like this - optCoercion ( (t1~t2) => ...co_B1... ) - -Just because it's a wild-card doesn't mean we are free to choose -whatever variable we like. For example it'd be wrong for optCoercion -to return - forall (co_B1:t1~t2). ...co_B1... -because now the co_B1 (which is really free) has been captured, and -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 applies a substitution to a coercion, --- *and* optimises it to reduce its size -optCoercion env co - | opt_NoOptCoercion = substTy env co - | otherwise = opt_co env False co - -type NormalCo = Coercion - -- Invariants: - -- * The substitution has been fully applied - -- * For trans coercions (co1 `trans` co2) - -- co1 is not a trans, and neither co1 nor co2 is identity - -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) - -type NormalNonIdCo = NormalCo -- Extra invariant: not the identity - -opt_co, opt_co' :: TvSubst - -> 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), - (text "env=" <+> ppr env) $$ - (text "input=" <+> ppr co) $$ - (text "simple=" <+> ppr simple_result) $$ - (text "opt=" <+> ppr co1) ) - co1 - where - co1 = opt_co' env sym co - same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2 - (s,t) = coercionKind (substTy env co) - (s1,t1) | sym = (t,s) - | otherwise = (s,t) - (s2,t2) = coercionKind co1 - - simple_result | sym = mkSymCoercion (substTy env co) - | otherwise = substTy 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 - 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) - -opt_co' env sym co@(ForAllTy co_var cor) - | isCoVar co_var - = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co ) - ForAllTy co_var' cor' - 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'] - - where - (co1 : cos1) = cos - (co2 : _) = cos1 - - ty1' = substTy env co1 - ty2' = substTy env co2 - - -- These opt_cos have the sym pushed into them - opt_co1 = opt_co env sym co1 - opt_co2 = opt_co env sym co2 - - the_unary_opt_co = TyConApp tc [opt_co1] - - 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 - -------------- -opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transL = zipWith opt_trans - -opt_trans :: NormalCo -> NormalCo -> NormalCo -opt_trans co1 co2 - | isIdNormCo 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 - -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 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 - then co2b - else opt_trans2 co1_2a co2b - -opt_trans2 co1 co2 - = mkTransCoercion co1 co2 - ------- -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 inside (s~t)=>r --- We re-use the CoVar rather than using mkCoPredTy --- See Note [Subtle shadowing in coercions] -opt_trans_rule co1 co2 - | Just (cv1,r1) <- splitForAllTy_maybe co1 - , 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))) - (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))) - (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)) - -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 $ - if sym - then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args) - else TyConApp ax_tc (opt_transL ax_args cos) - - | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2 - , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1 - = Just $ - if sym - then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos)) - else TyConApp ax_tc (opt_transL cos ax_args) - 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 - -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 - 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 - -------------- -compatible_co :: Coercion -> Coercion -> Bool --- Check whether (co1 . co2) will be well-kinded -compatible_co co1 co2 - = x1 `coreEqType` x2 - where - (_,x1) = coercionKind co1 - (x2,_) = coercionKind co2 - -------------- -etaForAll_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 - = Just (tv, r) - - | (ty1,ty2) <- coercionKind co - , Just (tv1, _) <- splitTypeForAll_maybe ty1 - , Just (tv2, _) <- splitTypeForAll_maybe ty2 - , tyVarKind tv1 `eqKind` tyVarKind tv2 - = Just (tv1, mkInstCoercion 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) - - | 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} +% +% (c) The University of Glasgow 2006 +% + +\begin{code} +module OptCoercion ( optCoercion ) where + +#include "HsVersions.h" + +import Coercion +import Type hiding( substTyVarBndr, substTy, extendTvSubst ) +import TyCon +import Var +import VarSet +import VarEnv +import StaticFlags ( opt_NoOptCoercion ) +import Outputable +import Pair +import Maybes( allMaybes ) +import FastString +\end{code} + +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +Note [Subtle shadowing in coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose we optimising a coercion + optCoercion (forall (co_X5:t1~t2). ...co_B1...) +The co_X5 is a wild-card; the bound variable of a coercion for-all +should never appear in the body of the forall. Indeed we often +write it like this + optCoercion ( (t1~t2) => ...co_B1... ) + +Just because it's a wild-card doesn't mean we are free to choose +whatever variable we like. For example it'd be wrong for optCoercion +to return + forall (co_B1:t1~t2). ...co_B1... +because now the co_B1 (which is really free) has been captured, and +subsequent substitutions will go wrong. That's why we can't use +mkCoPredTy in the ForAll case, where this note appears. + +\begin{code} +optCoercion :: CvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion env co + | opt_NoOptCoercion = substCo env co + | otherwise = opt_co env False co + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +opt_co, opt_co' :: CvSubst + -> Bool -- True <=> return (sym co) + -> Coercion + -> NormalCo +opt_co = opt_co' +{- +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) + where + co1 = opt_co' env sym 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) + Pair s2 t2 = coercionKind co1 + + simple_result | sym = mkSymCo (substCo env co) + | otherwise = substCo env 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) = mkTyConAppCo 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') -> mkForAllCo tv' (opt_co env' sym co) + -- Use the "mk" functions to check for nested Refls + +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' = substTy env ty1 + ty2' = substTy env ty2 + +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 + 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 + co' = opt_co env sym co + +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 + + -- 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 + + | otherwise = InstCo co' ty' + + where + co' = opt_co env sym co + ty' = substTy env ty + +------------- +opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList = zipWith opt_trans + +opt_trans :: NormalCo -> NormalCo -> NormalCo +opt_trans 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 + | isReflCo co2 = co1 + | otherwise = opt_trans2 co1 co2 + +opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +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 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 co1_2a co2b + +opt_trans2 co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +-- 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) + +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) + +-- Push transitivity inside forall +opt_trans_rule co1 co2 + | 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 + + -- TrPushAxR/TrPushSymAxR + | Just (sym, con, cos1) <- co1_is_axiom_maybe + , Just cos2 <- matchAxiom sym con co2 + = fireTransRule "TrPushAxR" co1 co2 $ + if sym + then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1) + else AxiomInstCo con (opt_transList cos1 cos2) + + -- TrPushAxL/TrPushSymAxL + | Just (sym, con, cos2) <- co2_is_axiom_maybe + , Just cos1 <- matchAxiom (not sym) con co1 + = fireTransRule "TrPushAxL" co1 co2 $ + if sym + 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 + | Pair ty1 _ <- coercionKind co1 + , Pair _ ty2 <- coercionKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + Refl ty2 + +opt_trans_rule _ _ = 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 -> allMaybes (map (liftCoSubstTyVar subst) qtvs) + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + Pair _ x1 = coercionKind co1 + Pair x2 _ = coercionKind co2 + +------------- +etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) +-- Try to make the coercion be of form (forall tv. co) +etaForAllCo_maybe co + | Just (tv, r) <- splitForAllCo_maybe co + = Just (tv, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_maybe ty1 + , Just (tv2, _) <- splitForAllTy_maybe ty2 + , tyVarKind tv1 `eqKind` tyVarKind tv2 + = Just (tv1, mkInstCo co (mkTyVarTy tv1)) + + | otherwise + = Nothing + +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 +\end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 5804d49..9152076 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, tupleTyConArity, @@ -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 @@ -376,17 +392,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 @@ -396,7 +401,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 } @@ -470,18 +475,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 @@ -541,7 +542,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: @@ -572,20 +573,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] @@ -684,6 +671,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} %* * %************************************************************************ @@ -871,17 +883,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, @@ -959,11 +960,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 @@ -995,9 +996,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? @@ -1039,7 +1039,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! @@ -1109,19 +1109,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). @@ -1151,14 +1138,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 @@ -1166,26 +1154,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} @@ -1203,7 +1186,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 @@ -1256,9 +1238,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 @@ -1328,6 +1315,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 @@ -1335,7 +1323,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) @@ -1352,7 +1340,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 @@ -1386,18 +1374,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) @@ -1412,4 +1388,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 c9bf3f5..995d7a9 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 @@ -219,31 +231,9 @@ coreView :: Type -> Maybe Type -- its underlying representation type. -- Returns Nothing if there is nothing to look through. -- --- In the case of @newtype@s, it returns one of: --- --- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated) --- --- 2) The newtype representation (otherwise), meaning the --- type written in the RHS of the newtype declaration, --- which may itself be a newtype --- --- For example, with: --- --- > newtype R = MkR S --- > newtype S = MkS T --- > newtype T = MkT (T -> T) --- --- 'expandNewTcApp' on: --- --- * @R@ gives @Just S@ --- * @S@ gives @Just T@ --- * @T@ gives @Nothing@ (no expansion) - -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing -coreView (PredTy p) - | isEqPred p = Nothing - | otherwise = Just (predTypeRep p) +coreView (PredTy p) = Just (predTypeRep p) coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') -- Its important to use mkAppTys, rather than (foldl AppTy), @@ -252,7 +242,6 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc coreView _ = Nothing - ----------------------------------------------- {-# INLINE tcView #-} tcView :: Type -> Maybe Type @@ -283,14 +272,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 +286,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 @@ -384,10 +359,9 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type) repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) - | isDecomposableTyCon tc || length tys > tyConArity tc - = case snocView tys of -- never create unsaturated type family apps - Just (tys', ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing + | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! repSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) @@ -427,8 +401,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 +469,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 +571,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 +718,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 +752,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. ) + +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 +872,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 +904,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 +953,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 +1007,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 +1025,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 +1092,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 +1100,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} - +eqKind :: Kind -> Kind -> Bool +eqKind = eqType -%************************************************************************ -%* * - Comparision for source types - (We don't use instances so that we know where it happens) -%* * -%************************************************************************ - -\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 +eqType t1 t2 = isEqual $ cmpType t1 t2 -tcCmpTypes :: [Type] -> [Type] -> Ordering -tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -tcEqPred :: PredType -> PredType -> Bool -tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool -tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 +eqPred :: PredType -> PredType -> Bool +eqPred p1 p2 = isEqual $ cmpPred p1 p2 -tcCmpPred :: PredType -> PredType -> Ordering -tcCmpPred p1 p2 = 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 +1155,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 +1218,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 +1230,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 +1247,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 +1265,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 +1314,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 +1340,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 +1365,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 +1443,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 +1481,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 7fdf4ae..db41403 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,35 @@ 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 Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ + -- See Note [Equality-constrained types] | ForAllTy - TyVar + TyCoVar -- Type variable 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 +178,15 @@ 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:*) $ + FunTy (PredTy (EqPred a [b]) $ + blah + ------------------------------------- Note [PredTy] @@ -197,11 +207,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 +252,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 +348,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 +359,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 +367,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 +375,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 +481,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 +545,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,94 +555,43 @@ 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) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ - ifPprDebug (ptext (sLit "")) <> (ppr pred) -ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys + ifPprDebug (ptext (sLit "")) <> (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 "") - else ptext (sLit "")) - | otherwise = empty - ppr_tvar :: TyVar -> SDoc ppr_tvar tv -- Note [Infix type variables] | isSymOcc (getOccName tv) = parens (ppr tv) @@ -579,8 +603,9 @@ pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv - | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) +pprTvBndr tv + | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv \end{code} @@ -603,6 +628,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 "") + else ptext (sLit "")) + | 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 d519f62..fe8fd59 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 2acf71e..9c448ce 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,9 @@ 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 prs = any (\(s,t) -> cant_match s t) prs 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 +329,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 (zipEqual "typesCantMatch" tys1 tys2) cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc @@ -370,7 +351,6 @@ dataConCannotMatch tys con \end{code} - %************************************************************************ %* * Unification @@ -415,7 +395,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 0000000..9e847d6 --- /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 ca6766a..4994e3f 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 69ae84f..165dbda 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 94de62a..ecb8a98 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 dbdf6e1..4676e18 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: (, 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 8484410..4910464 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 1556626..c30bfed 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 8cc2bec..a6d9b2a 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 1a099e3..c7020ea 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 0ffaa60..d41be1e 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 152c51d..d784984 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 12b1b6f..d0785e5 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 329cb63..9c7af44 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 8856afd..a27afea 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 f32cf78..9c81d30 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 diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml index b84134a..9c48f7d 100644 --- a/docs/users_guide/debugging.xml +++ b/docs/users_guide/debugging.xml @@ -24,8 +24,9 @@ a short form…). You can get all of these at once (lots of output) by using , or most of them with - . Some of the most useful ones - are: + . You can prevent them from clogging up + your standard output by passing . + Some of the most useful ones are: diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 96dfc1b..0faefbb 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -2247,6 +2247,12 @@ phase n - + + Dump to files instead of stdout + dynamic + - + + Dump assembly dynamic diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs index c2e6973..fc5cf00 100644 --- a/ghc/GhciTags.hs +++ b/ghc/GhciTags.hs @@ -101,10 +101,11 @@ listModuleTags m = do ] where - tyThing2TagKind (AnId _) = 'v' + tyThing2TagKind (AnId _) = 'v' tyThing2TagKind (ADataCon _) = 'd' - tyThing2TagKind (ATyCon _) = 't' - tyThing2TagKind (AClass _) = 'c' + tyThing2TagKind (ATyCon _) = 't' + tyThing2TagKind (AClass _) = 'c' + tyThing2TagKind (ACoAxiom _) = 'x' data TagInfo = TagInfo diff --git a/rts/Schedule.c b/rts/Schedule.c index f5cb568..9636223 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1447,6 +1447,12 @@ delete_threads_and_gc: recent_activity = ACTIVITY_YES; } + if (heap_census) { + debugTrace(DEBUG_sched, "performing heap census"); + heapCensus(); + performHeapProfile = rtsFalse; + } + #if defined(THREADED_RTS) if (gc_type == PENDING_GC_PAR) { @@ -1454,12 +1460,6 @@ delete_threads_and_gc: } #endif - if (heap_census) { - debugTrace(DEBUG_sched, "performing heap census"); - heapCensus(); - performHeapProfile = rtsFalse; - } - if (heap_overflow && sched_state < SCHED_INTERRUPTING) { // GC set the heap_overflow flag, so we should proceed with // an orderly shutdown now. Ultimately we want the main diff --git a/rts/Stats.c b/rts/Stats.c index fa38472..3036ed7 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -547,6 +547,18 @@ stat_exit(int alloc) gc_elapsed += GC_coll_elapsed[i]; } + init_cpu = end_init_cpu - start_init_cpu; + init_elapsed = end_init_elapsed - start_init_elapsed; + + exit_cpu = end_exit_cpu - start_exit_cpu; + exit_elapsed = end_exit_elapsed - start_exit_elapsed; + + mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed; + + mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu + - PROF_VAL(RP_tot_time + HC_tot_time); + if (mut_cpu < 0) { mut_cpu = 0; } + if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) { showStgWord64(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/); @@ -635,21 +647,9 @@ stat_exit(int alloc) } #endif - init_cpu = end_init_cpu - start_init_cpu; - init_elapsed = end_init_elapsed - start_init_elapsed; - - exit_cpu = end_exit_cpu - start_exit_cpu; - exit_elapsed = end_exit_elapsed - start_exit_elapsed; - statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed)); - mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed; - - mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu - - PROF_VAL(RP_tot_time + HC_tot_time); - if (mut_cpu < 0) { mut_cpu = 0; } - statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed)); statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n",