diff options
Diffstat (limited to 'compiler/basicTypes')
| -rw-r--r-- | compiler/basicTypes/DataCon.lhs | 88 | ||||
| -rw-r--r-- | compiler/basicTypes/Id.lhs | 39 | ||||
| -rw-r--r-- | compiler/basicTypes/IdInfo.lhs | 5 | ||||
| -rw-r--r-- | compiler/basicTypes/IdInfo.lhs-boot | 2 | ||||
| -rw-r--r-- | compiler/basicTypes/MkId.lhs | 121 | ||||
| -rw-r--r-- | compiler/basicTypes/Var.lhs | 87 | ||||
| -rw-r--r-- | compiler/basicTypes/VarEnv.lhs | 5 | ||||
| -rw-r--r-- | compiler/basicTypes/VarSet.lhs | 6 |
8 files changed, 169 insertions, 184 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 5a62326718..312ae943a8 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 fd65fe4009..5ac261255c 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -23,7 +23,7 @@ -- * 'Var.Var': see "Var#name_types" module Id ( -- * The main types - Id, DictId, + Var, Id, isId, -- ** Simple construction mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, @@ -34,8 +34,7 @@ module Id ( -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, - isId, idPrimRep, - recordSelectorFieldLabel, + idPrimRep, recordSelectorFieldLabel, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, @@ -46,7 +45,8 @@ module Id ( -- ** Predicates on Ids - isImplicitId, isDeadBinder, isDictId, isStrictId, + isImplicitId, isDeadBinder, + isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, isClassOpId_maybe, isDFunId, dfunNSilent, @@ -57,6 +57,9 @@ module Id ( isTickBoxOp, isTickBoxOp_maybe, hasNoBinding, + -- ** Evidence variables + DictId, isDictId, isEvVar, evVarPred, + -- ** Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, idInlineActivation, setInlineActivation, idRuleMatchInfo, @@ -95,8 +98,8 @@ import IdInfo import BasicTypes -- Imported and re-exported -import Var( Var, Id, DictId, - idInfo, idDetails, globaliseId, +import Var( Var, Id, DictId, EvVar, + idInfo, idDetails, globaliseId, varType, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var @@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -isDictId :: Id -> Bool -isDictId id = isDictTy (idType id) - hasNoBinding :: Id -> Bool -- ^ Returns @True@ of an 'Id' which may not have a -- binding, even though it is defined in this module. @@ -448,6 +447,26 @@ isTickBoxOp_maybe id = %************************************************************************ %* * + Evidence variables +%* * +%************************************************************************ + +\begin{code} +isEvVar :: Var -> Bool +isEvVar var = isPredTy (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +evVarPred :: EvVar -> PredType +evVarPred var + = case splitPredTy_maybe (varType var) of + Just pred -> pred + Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var)) +\end{code} + +%************************************************************************ +%* * \subsection{IdInfo stuff} %* * %************************************************************************ diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index ec1f122176..c106f5397c 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -10,7 +10,7 @@ Haskell. [WDP 94/11]) \begin{code} module IdInfo ( -- * The IdDetails type - IdDetails(..), pprIdDetails, + IdDetails(..), pprIdDetails, coVarDetails, -- * The IdInfo type IdInfo, -- Abstract @@ -141,6 +141,9 @@ data IdDetails -- implemented with a newtype, so it might be bad -- to be strict on this dictionary +coVarDetails :: IdDetails +coVarDetails = VanillaId + instance Outputable IdDetails where ppr = pprIdDetails diff --git a/compiler/basicTypes/IdInfo.lhs-boot b/compiler/basicTypes/IdInfo.lhs-boot index 4195156f27..257e1c6e5e 100644 --- a/compiler/basicTypes/IdInfo.lhs-boot +++ b/compiler/basicTypes/IdInfo.lhs-boot @@ -4,5 +4,7 @@ import Outputable data IdInfo data IdDetails +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails pprIdDetails :: IdDetails -> SDoc \end{code}
\ No newline at end of file diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 5aebd37259..4d0e7f81a9 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} @@ -858,7 +848,7 @@ mkDictFunTy tvs theta clas tys (classSCTheta clas) -- See Note [Silent Superclass Arguments] discard pred = isEmptyVarSet (tyVarsOfPred pred) - || any (`tcEqPred` pred) theta + || any (`eqPred` pred) theta -- See the DFun Superclass Invariant in TcInstDcls \end{code} @@ -885,12 +875,13 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} -lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name -unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId +lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name +unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId \end{code} \begin{code} @@ -908,7 +899,7 @@ unsafeCoerceId (mkFunTy argAlphaTy openBetaTy) [x] = mkTemplateLocals [argAlphaTy] rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy) + Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -944,7 +935,7 @@ seqId = pcMiscPrelId seqName ty info match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- See Note [Built-in RULES for seq] match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] - = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty, + = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, scrut, expr]) match_seq_of_cast _ _ = Nothing @@ -1054,6 +1045,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 13810da530..3c3ff7f440 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 f275714e5c..fca625692f 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -6,7 +6,7 @@ \begin{code} module VarEnv ( -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, + VarEnv, IdEnv, TyVarEnv, CoVarEnv, -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, @@ -29,7 +29,7 @@ module VarEnv ( emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, + unionInScope, elemInScopeSet, uniqAway, -- * The RnEnv2 type RnEnv2, @@ -343,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) type VarEnv elt = UniqFM elt type IdEnv elt = VarEnv elt type TyVarEnv elt = VarEnv elt +type CoVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs index 6f03aad1bf..e0ff52d690 100644 --- a/compiler/basicTypes/VarSet.lhs +++ b/compiler/basicTypes/VarSet.lhs @@ -6,7 +6,7 @@ \begin{code} module VarSet ( -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, + VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet, -- ** Manipulating these sets emptyVarSet, unitVarSet, mkVarSet, @@ -22,7 +22,7 @@ module VarSet ( #include "HsVersions.h" -import Var ( Var, TyVar, Id ) +import Var ( Var, TyVar, CoVar, TyCoVar, Id ) import Unique import UniqSet \end{code} @@ -37,6 +37,8 @@ import UniqSet type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar +type TyCoVarSet = UniqSet TyCoVar +type CoVarSet = UniqSet CoVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet |