inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
- SuccessFlag(..), succeeded, failed, successIf
+ SuccessFlag(..), succeeded, failed, successIf,
+
+ FractionalLit(..), negateFractionalLit, integralFractionalLit
) where
import FastString
import Outputable
import Data.Data hiding (Fixity)
+import Data.Function (on)
\end{code}
%************************************************************************
isEarlyActive _ = False
\end{code}
+
+
+\begin{code}
+-- Used (instead of Rational) to represent exactly the floating point literal that we
+-- encountered in the user's source program. This allows us to pretty-print exactly what
+-- the user wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+ = FL { fl_text :: String -- How the value was written in the source
+ , fl_value :: Rational -- Numeric value of the literal
+ }
+ deriving (Data, Typeable, Show)
+ -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
+
+negateFractionalLit :: FractionalLit -> FractionalLit
+negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
+negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
+
+integralFractionalLit :: Integer -> FractionalLit
+integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+ (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+ compare = compare `on` fl_value
+
+instance Outputable FractionalLit where
+ ppr = text . fl_text
+\end{code}
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
- dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+ dataConEqSpec, eqSpecPreds, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
- isVanillaDataCon, classDataCon,
+ isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
#include "HsVersions.h"
import Type
+import Unify
import Coercion
import TyCon
import Class
import qualified Data.Data as Data
import Data.Char
import Data.Word
-import Data.List ( partition )
\end{code}
-- 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
-- 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.
-- 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 = ...
-- 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
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,
-- 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
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)
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
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
--
-- 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:
--
--
-- 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
-- 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
[] -> 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}
-- * 'Var.Var': see "Var#name_types"
module Id (
-- * The main types
- Id, DictId,
+ Var, Id, isId,
-- ** Simple construction
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
- isId, idPrimRep,
- recordSelectorFieldLabel,
+ idPrimRep, recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
-- ** Predicates on Ids
- isImplicitId, isDeadBinder, isDictId, isStrictId,
+ isImplicitId, isDeadBinder,
+ isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId, dfunNSilent,
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
+ -- ** Evidence variables
+ DictId, isDictId, isEvVar, evVarPred,
+
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
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
-- 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.
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
\begin{code}
module IdInfo (
-- * The IdDetails type
- IdDetails(..), pprIdDetails,
+ IdDetails(..), pprIdDetails, coVarDetails,
-- * The IdInfo type
IdInfo, -- Abstract
-- 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
data IdInfo
data IdDetails
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
pprIdDetails :: IdDetails -> SDoc
\end{code}
\ No newline at end of file
-- 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
import ForeignCall
import DataCon
import Id
-import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar )
+import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
+import Pair
import Outputable
import FastString
import ListSetOps
= 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) --------------
-- 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
`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
-- ...(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
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
[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
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}
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
-- 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')
-- 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
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
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}
(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}
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}
(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
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
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}
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,
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
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
-- 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
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}
%************************************************************************
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
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
\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
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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
%************************************************************************
\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
\begin{code}
module VarEnv (
-- * Var, Id and TyVar environments (maps)
- VarEnv, IdEnv, TyVarEnv,
+ VarEnv, IdEnv, TyVarEnv, CoVarEnv,
-- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv,
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, lookupInScope_Directly,
- unionInScope, elemInScopeSet, uniqAway,
+ unionInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type
RnEnv2,
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
\begin{code}
module VarSet (
-- * Var, Id and TyVar set types
- VarSet, IdSet, TyVarSet,
+ VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet,
-- ** Manipulating these sets
emptyVarSet, unitVarSet, mkVarSet,
#include "HsVersions.h"
-import Var ( Var, TyVar, Id )
+import Var ( Var, TyVar, CoVar, TyCoVar, Id )
import Unique
import UniqSet
\end{code}
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
module Cmm
( CmmGraph, GenCmmGraph(..), CmmBlock
, CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
- , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+ , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
, modifyGraph
, lastNode, replaceLastNode, insertBetween
data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
-type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x))
+type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
+type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
{-# 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.
global to one compiler session.
-}
+-- EZY: It might be helpful to have an easy way of dumping the "pre"
+-- input for any given phase, besides just turning it all on with
+-- -ddump-cmmz
+
cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
- -- Why bother doing it this early?
- -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
- -- (dualLivenessWithInsertion callPPs) g
- -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
- -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
- -- (removeDeadAssignmentsAndReloads callPPs) g
- dump Opt_D_dump_cmmz "Pre common block elimination" g
- g <- return $ elimCommonBlocks g
- dump Opt_D_dump_cmmz "Post common block elimination" g
+ -- Why bother doing these early: dualLivenessWithInsertion,
+ -- insertLateReloads, rewriteAssignments?
+ ----------- Eliminate common blocks -------------------
+ g <- return $ elimCommonBlocks g
+ dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_ elimCommonBlocks
----------- Proc points -------------------
let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
- dump Opt_D_dump_cmmz "Post Proc Points Added" g
+ dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
- g <-
- -- pprTrace "pre Spills" (ppr g) $
- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
- (dualLivenessWithInsertion procPoints) g
- -- Insert spills at defns; reloads at return points
- g <-
- -- pprTrace "pre insertLateReloads" (ppr g) $
- runOptimization $ insertLateReloads g -- Duplicate reloads just before uses
- dump Opt_D_dump_cmmz "Post late reloads" g
- g <-
- -- pprTrace "post insertLateReloads" (ppr g) $
- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
- (removeDeadAssignmentsAndReloads procPoints) g
- -- Remove redundant reloads (and any other redundant asst)
-
- ----------- Debug only: add code to put zero in dead stack slots----
- -- Debugging: stubbing slots on death can cause crashes early
- g <- -- trace "post dead-assign elim" $
- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+ g <- run $ dualLivenessWithInsertion procPoints g
+ dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
+ ----------- Sink and inline assignments -------------------
+ g <- runOptimization $ rewriteAssignments g
+ dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+
+ ----------- Eliminate dead assignments -------------------
+ -- Remove redundant reloads (and any other redundant asst)
+ g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
+ dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g
+
+ ----------- Zero dead stack slots (Debug only) ---------------
+ -- Debugging: stubbing slots on death can cause crashes early
+ g <- if opt_StubDeadValues
+ then run $ stubSlotsOnDeath g
+ else return g
+ dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
------------ Manifest the stack pointer --------
g <- run $ manifestSP spEntryMap areaMap entry_off g
- dump Opt_D_dump_cmmz "after manifestSP" g
+ dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap <- run $ procPointAnalysis procPoints g
- dump Opt_D_dump_cmmz "procpoint map" procPointMap
+ dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
- mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
+ mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+ mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
- let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
- let gs'' = map (bundleCAFs cafEnv) gs'
- mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
- return (localCAFs, gs'')
+ gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
+ mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
+ gs <- return $ map (bundleCAFs cafEnv) gs
+ mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+ return (localCAFs, gs)
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
- dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+ dump f txt g = do
+ -- ToDo: No easy way of say "dump all the cmmz, *and* split
+ -- them into files." Also, -ddump-cmmz doesn't play nicely
+ -- with -ddump-to-file, since the headers get omitted.
+ dumpIfSet_dyn dflags f txt (ppr g)
+ when (not (dopt f dflags)) $
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-- Runs an optional transformation/analysis (and should
-- thus be subject to optimization fuel)
runOptimization = runFuelIO (hsc_OptFuel hsc_env)
- -- pass 'run' or 'runOptimization' for 'r'
- dual_rewrite r flag txt pass g =
- do dump flag ("Pre " ++ txt) g
- g <- r $ pass g
- dump flag ("Post " ++ txt) $ g
- return g
-
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
module CmmNode
( CmmNode(..)
, UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
- , mapExp, mapExpDeep, foldExp, foldExpDeep
+ , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
)
where
CmmActuals -> -- zero or more arguments
CmmNode O O
-- Semantics: kills only result regs; all other regs (both GlobalReg
- -- and LocalReg) are preserved
+ -- and LocalReg) are preserved. But there is a current
+ -- bug for what can be put in arguments, see
+ -- Note [Register Parameter Passing]
CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
-- moment of the call. Later stages can use this to give liveness
-- everywhere, which in turn guides register allocation.
-- It is the companion of cml_args; cml_args says which stack words
--- hold parameters, while cml_arg_regs says which global regs hold parameters
+-- hold parameters, while cml_arg_regs says which global regs hold parameters.
+-- But do note [Register parameter passing]
cml_args :: ByteOff,
-- Byte offset, from the *old* end of the Area associated with
-- Always the last node of a block
tgt :: ForeignTarget, -- call target and convention
res :: CmmFormals, -- zero or more results
- args :: CmmActuals, -- zero or more arguments
+ args :: CmmActuals, -- zero or more arguments; see Note [Register parameter passing]
succ :: Label, -- Label of continuation
updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
intrbl:: Bool -- whether or not the call is interruptible
~~~~~~~~~~~~~~~~~~~~~~~
A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
a CmmForeignCall call is used for *safe* foreign calls.
-Unsafe ones are easy: think of them as a "fat machine instruction".
-In particular, they do *not* kill all live registers (there was a bit
-of code in GHC that conservatively assumed otherwise.)
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction". In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.) However, see [Register parameter passing].
Safe ones are trickier. A safe foreign call
r = f(x)
Note that a safe foreign call needs an info table.
-}
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention. For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing. These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call. This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments. This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently. We should fix this!
+-}
+
---------------------------------------------
-- Eq instance of CmmNode
-- It is a shame GHC cannot infer it by itself :(
( "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 ),
( "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 ),
-{-# LANGUAGE GADTs,NoMonoLocalBinds #-}
+{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#if __GLASGOW_HASKELL__ >= 701
-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
--, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , availRegsLattice
- , cmmAvailableReloads
- , insertLateReloads
+ , rewriteAssignments
, removeDeadAssignmentsAndReloads
)
where
import CmmExpr
import CmmLive
import OptimizationFuel
+import StgCmmUtils
import Control.Monad
import Outputable hiding (empty)
import qualified Outputable as PP
import UniqSet
+import UniqFM
+import Unique
-import Compiler.Hoopl
+import Compiler.Hoopl hiding (Unique)
import Data.Maybe
import Prelude hiding (succ, zip)
text "after"{-, ppr m-}]) $
Just $ mkMiddles $ [m, spill reg]
else Nothing
- middle m@(CmmUnsafeForeignCall _ fs _) live = return $
- case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
- map reload (uniqSetToList (kill fs (in_regs live))) of
- [] -> Nothing
- reloads -> Just $ mkMiddles (m : reloads)
middle _ _ = return Nothing
nothing _ _ = return Nothing
spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
-----------------------------------------------------------------
---- sinking reloads
-
--- The idea is to compute at each point the set of registers such that
--- on every path to the point, the register is defined by a Reload
--- instruction. Then, if a use appears at such a point, we can safely
--- insert a Reload right before the use. Finally, we can eliminate
--- the early reloads along with other dead assignments.
-
-data AvailRegs = UniverseMinus RegSet
- | AvailRegs RegSet
-
-
-availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add
- where empty = UniverseMinus emptyRegSet
- -- | compute in the Tx monad to track whether anything has changed
- add _ (OldFact old) (NewFact new) =
- if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
- where join = interAvail new old
-
-
-interAvail :: AvailRegs -> AvailRegs -> AvailRegs
-interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
-interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
-interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
-interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
-
-smallerAvail :: AvailRegs -> AvailRegs -> Bool
-smallerAvail (AvailRegs _) (UniverseMinus _) = True
-smallerAvail (UniverseMinus _) (AvailRegs _) = False
-smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
-smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
-
-extendAvail :: AvailRegs -> LocalReg -> AvailRegs
-extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
-extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
-
-delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
-
-elemAvail :: AvailRegs -> LocalReg -> Bool
-elemAvail (UniverseMinus s) r = not $ elemRegSet r s
-elemAvail (AvailRegs s) r = elemRegSet r s
-
-cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
-cmmAvailableReloads g =
- liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
- analFwd availRegsLattice availReloadsTransfer
-
-availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
-availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
-
-middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
-middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
- | l `isStackSlotOf` r = extendAvail avail r
-middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
- | l `isStackSlotOf` r = avail
-middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (CmmStore {}) avail = avail
-middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet
-middleAvail (CmmComment {}) avail = avail
-
-lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
-lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = map (\id -> (id, avail)) $ successors l
-
-insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
-insertLateReloads g =
- liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
- analRewFwd availRegsLattice availReloadsTransfer rewrites
- where rewrites = mkFRewrite3 first middle last
- first _ _ = return Nothing
- middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
- last l avail = return $ maybe_reload_before avail l (mkLast l)
- maybe_reload_before avail node tail =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then Nothing
- else Just $ reloadTail used tail
- reloadTail regset t = foldl rel t $ uniqSetToList regset
- where rel t r = mkMiddle (reload r) <*> t
-
removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
removeDeadAssignmentsAndReloads procPoints g =
liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
-- but GHC panics while compiling, see bug #4045.
middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+ -- XXX maybe this should be somewhere else...
+ middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
+ middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
middle _ _ = return Nothing
nothing _ _ = return Nothing
+----------------------------------------------------------------
+--- Usage information
+
+-- We decorate all register assignments with usage information,
+-- that is, the maximum number of times the register is referenced
+-- while it is live along all outgoing control paths. There are a few
+-- subtleties here:
+--
+-- - If a register goes dead, and then becomes live again, the usages
+-- of the disjoint live range don't count towards the original range.
+--
+-- a = 1; // used once
+-- b = a;
+-- a = 2; // used once
+-- c = a;
+--
+-- - A register may be used multiple times, but these all reside in
+-- different control paths, such that any given execution only uses
+-- it once. In that case, the usage count may still be 1.
+--
+-- a = 1; // used once
+-- if (b) {
+-- c = a + 3;
+-- } else {
+-- c = a + 1;
+-- }
+--
+-- This policy corresponds to an inlining strategy that does not
+-- duplicate computation but may increase binary size.
+--
+-- - If we naively implement a usage count, we have a counting to
+-- infinity problem across joins. Furthermore, knowing that
+-- something is used 2 or more times in one runtime execution isn't
+-- particularly useful for optimizations (inlining may be beneficial,
+-- but there's no way of knowing that without register pressure
+-- information.)
+--
+-- while (...) {
+-- // first iteration, b used once
+-- // second iteration, b used twice
+-- // third iteration ...
+-- a = b;
+-- }
+-- // b used zero times
+--
+-- There is an orthogonal question, which is that for every runtime
+-- execution, the register may be used only once, but if we inline it
+-- in every conditional path, the binary size might increase a lot.
+-- But tracking this information would be tricky, because it violates
+-- the finite lattice restriction Hoopl requires for termination;
+-- we'd thus need to supply an alternate proof, which is probably
+-- something we should defer until we actually have an optimization
+-- that would take advantage of this. (This might also interact
+-- strangely with liveness information.)
+--
+-- a = ...;
+-- // a is used one time, but in X different paths
+-- case (b) of
+-- 1 -> ... a ...
+-- 2 -> ... a ...
+-- 3 -> ... a ...
+-- ...
+--
+-- This analysis is very similar to liveness analysis; we just keep a
+-- little extra info. (Maybe we should move it to CmmLive, and subsume
+-- the old liveness analysis.)
+
+data RegUsage = SingleUse | ManyUse
+ deriving (Ord, Eq, Show)
+-- Absence in map = ZeroUse
+
+{-
+-- minBound is bottom, maxBound is top, least-upper-bound is max
+-- ToDo: Put this in Hoopl. Note that this isn't as useful as I
+-- originally hoped, because you usually want to leave out the bottom
+-- element when you have things like this put in maps. Maybe f is
+-- useful on its own as a combining function.
+boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a
+boundedOrdLattice n = DataflowLattice n minBound f
+ where f _ (OldFact x) (NewFact y)
+ | x >= y = (NoChange, x)
+ | otherwise = (SomeChange, y)
+-}
+
+-- Custom node type we'll rewrite to. CmmAssign nodes to local
+-- registers are replaced with AssignLocal nodes.
+data WithRegUsage n e x where
+ Plain :: n e x -> WithRegUsage n e x
+ AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
+
+instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
+ foldRegsUsed f z (Plain n) = foldRegsUsed f z n
+ foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
+ foldRegsDefd f z (Plain n) = foldRegsDefd f z n
+ foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
+
+instance NonLocal n => NonLocal (WithRegUsage n) where
+ entryLabel (Plain n) = entryLabel n
+ successors (Plain n) = successors n
+
+liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x
+liftRegUsage = mapGraph Plain
+
+eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x
+eraseRegUsage = mapGraph f
+ where f :: WithRegUsage CmmNode e x -> CmmNode e x
+ f (AssignLocal l e _) = CmmAssign (CmmLocal l) e
+ f (Plain n) = n
+
+type UsageMap = UniqFM RegUsage
+
+usageLattice :: DataflowLattice UsageMap
+usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
+ where f _ (OldFact x) (NewFact y)
+ | x >= y = (NoChange, x)
+ | otherwise = (SomeChange, y)
+
+-- We reuse the names 'gen' and 'kill', although we're doing something
+-- slightly different from the Dragon Book
+usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
+usageTransfer = mkBTransfer3 first middle last
+ where first _ f = f
+ middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
+ middle n f = gen_kill n f
+ last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap
+ -- Checking for CmmCall/CmmForeignCall is unnecessary, because
+ -- spills/reloads have already occurred by the time we do this
+ -- analysis.
+ -- XXX Deprecated warning is puzzling: what label are we
+ -- supposed to use?
+ -- ToDo: With a bit more cleverness here, we can avoid
+ -- disappointment and heartbreak associated with the inability
+ -- to inline into CmmCall and CmmForeignCall by
+ -- over-estimating the usage to be ManyUse.
+ last n f = gen_kill n (joinOutFacts usageLattice n f)
+ gen_kill a = gen a . kill a
+ gen a f = foldRegsUsed increaseUsage f a
+ kill a f = foldRegsDefd delFromUFM f a
+ increaseUsage f r = addToUFM_C combine f r SingleUse
+ where combine _ _ = ManyUse
+
+usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
+usageRewrite = mkBRewrite3 first middle last
+ where first _ _ = return Nothing
+ middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
+ middle (Plain (CmmAssign (CmmLocal l) e)) f
+ = return . Just
+ $ case lookupUFM f l of
+ Nothing -> emptyGraph
+ Just usage -> mkMiddle (AssignLocal l e usage)
+ middle _ _ = return Nothing
+ last _ _ = return Nothing
+
+type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
+annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
+annotateUsage vanilla_g =
+ let g = modifyGraph liftRegUsage vanilla_g
+ in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
+ analRewBwd usageLattice usageTransfer usageRewrite
+
+----------------------------------------------------------------
+--- Assignment tracking
+
+-- The idea is to maintain a map of local registers do expressions,
+-- such that the value of that register is the same as the value of that
+-- expression at any given time. We can then do several things,
+-- as described by Assignment.
+
+-- Assignment describes the various optimizations that are valid
+-- at a given point in the program.
+data Assignment =
+-- This assignment can always be inlined. It is cheap or single-use.
+ AlwaysInline CmmExpr
+-- This assignment should be sunk down to its first use. (This will
+-- increase code size if the register is used in multiple control flow
+-- paths, but won't increase execution time, and the reduction of
+-- register pressure is worth it.)
+ | AlwaysSink CmmExpr
+-- We cannot safely optimize occurrences of this local register. (This
+-- corresponds to top in the lattice structure.)
+ | NeverOptimize
+
+-- Extract the expression that is being assigned to
+xassign :: Assignment -> Maybe CmmExpr
+xassign (AlwaysInline e) = Just e
+xassign (AlwaysSink e) = Just e
+xassign NeverOptimize = Nothing
+
+-- Extracts the expression, but only if they're the same constructor
+xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr)
+xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e')
+xassign2 (AlwaysSink e, AlwaysSink e') = Just (e, e')
+xassign2 _ = Nothing
+
+-- Note: We'd like to make decisions about "not optimizing" as soon as
+-- possible, because this will make running the transfer function more
+-- efficient.
+type AssignmentMap = UniqFM Assignment
+
+assignmentLattice :: DataflowLattice AssignmentMap
+assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add)
+ where add _ (OldFact old) (NewFact new)
+ = case (old, new) of
+ (NeverOptimize, _) -> (NoChange, NeverOptimize)
+ (_, NeverOptimize) -> (SomeChange, NeverOptimize)
+ (xassign2 -> Just (e, e'))
+ | e == e' -> (NoChange, old)
+ | otherwise -> (SomeChange, NeverOptimize)
+ _ -> (SomeChange, NeverOptimize)
+
+-- Deletes sinks from assignment map, because /this/ is the place
+-- where it will be sunk to.
+deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
+deleteSinks n m = foldRegsUsed (adjustUFM f) m n
+ where f (AlwaysSink _) = NeverOptimize
+ f old = old
+
+-- Invalidates any expressions that use a register.
+invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap
+-- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance]
+ where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+{- This requires the entire spine of the map to be continually rebuilt,
+ - which causes crazy memory usage!
+invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
+ where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize
+ invalidateUsers' _ old = old
+-}
+
+-- Note [foldUFM performance]
+-- These calls to fold UFM no longer leak memory, but they do cause
+-- pretty killer amounts of allocation. So they'll be something to
+-- optimize; we need an algorithmic change to prevent us from having to
+-- traverse the /entire/ map continually.
+
+middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
+
+-- Algorithm for annotated assignments:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Add the assignment to our list of valid local assignments with
+-- the correct optimization policy.
+-- 3. Look for all assignments that reference that register and
+-- invalidate them.
+middleAssignment n@(AssignLocal r e usage) assign
+ = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
+ where add m = addToUFM m r
+ $ case usage of
+ SingleUse -> AlwaysInline e
+ ManyUse -> decide e
+ decide CmmLit{} = AlwaysInline e
+ decide CmmReg{} = AlwaysInline e
+ decide CmmLoad{} = AlwaysSink e
+ decide CmmStackSlot{} = AlwaysSink e
+ decide CmmMachOp{} = AlwaysSink e
+ -- We'll always inline simple operations on the global
+ -- registers, to reduce register pressure: Sp - 4 or Hp - 8
+ -- EZY: Justify this optimization more carefully.
+ decide CmmRegOff{} = AlwaysInline e
+
+-- Algorithm for unannotated assignments of global registers:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that reference this register and
+-- invalidate them.
+middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
+ = invalidateUsersOf reg . deleteSinks n $ assign
+
+-- Algorithm for unannotated assignments of *local* registers: do
+-- nothing (it's a reload, so no state should have changed)
+middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
+
+-- Algorithm for stores:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that load from memory locations that
+-- were clobbered by this store and invalidate them.
+middleAssignment (Plain n@(CmmStore lhs rhs)) assign
+ = let m = deleteSinks n assign
+ in foldUFM_Directly f m m -- [foldUFM performance]
+ where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+{- Also leaky
+ = mapUFM_Directly p . deleteSinks n $ assign
+ -- ToDo: There's a missed opportunity here: even if a memory
+ -- access we're attempting to sink gets clobbered at some
+ -- location, it's still /better/ to sink it to right before the
+ -- point where it gets clobbered. How might we do this?
+ -- Unfortunately, it's too late to change the assignment...
+ where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize
+ p _ old = old
+-}
+
+-- Assumption: Unsafe foreign calls don't clobber memory
+-- Since foreign calls clobber caller saved registers, we need
+-- invalidate any assignments that reference those global registers.
+-- This is kind of expensive. (One way to optimize this might be to
+-- store extra information about expressions that allow this and other
+-- checks to be done cheaply.)
+middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
+ = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
+ where deleteCallerSaves m = foldUFM_Directly f m m
+ f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+ g (CmmReg (CmmGlobal r)) _ | callerSaves r = True
+ g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
+ g _ b = b
+
+middleAssignment (Plain (CmmComment {})) assign
+ = assign
+
+-- Assumptions:
+-- * Writes using Hp do not overlap with any other memory locations
+-- (An important invariant being relied on here is that we only ever
+-- use Hp to allocate values on the heap, which appears to be the
+-- case given hpReg usage, and that our heap writing code doesn't
+-- do anything stupid like overlapping writes.)
+-- * Stack slots do not overlap with any other memory locations
+-- * Stack slots for different areas do not overlap
+-- * Stack slots within the same area and different offsets may
+-- overlap; we need to do a size check (see 'overlaps').
+-- * Register slots only overlap with themselves. (But this shouldn't
+-- happen in practice, because we'll fail to inline a reload across
+-- the next spill.)
+-- * Non stack-slot stores always conflict with each other. (This is
+-- not always the case; we could probably do something special for Hp)
+clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
+ -> (Unique, CmmExpr) -- (register, expression) that may be clobbered
+ -> Bool
+clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
+clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
+-- ToDo: Also catch MachOp case
+clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
+ | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
+clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
+ where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
+ = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
+ f (CmmLoad e _) = containsStackSlot e
+ f (CmmMachOp _ es) = or (map f es)
+ f _ = False
+ -- Maybe there's an invariant broken if this actually ever
+ -- returns True
+ containsStackSlot (CmmLoad{}) = True -- load of a load, all bets off
+ containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
+ containsStackSlot (CmmStackSlot{}) = True
+ containsStackSlot _ = False
+clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
+ where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
+ f _ = False
+clobbers _ (_, e) = f e
+ where f (CmmLoad (CmmStackSlot _ _) _) = False
+ f (CmmLoad{}) = True -- conservative
+ f (CmmMachOp _ es) = or (map f es)
+ f _ = False
+
+-- Check for memory overlapping.
+-- Diagram:
+-- 4 8 12
+-- s -w- o
+-- [ I32 ]
+-- [ F64 ]
+-- s' -w'- o'
+type CallSubArea = (AreaId, Int, Int) -- area, offset, width
+overlaps :: CallSubArea -> CallSubArea -> Bool
+overlaps (a, _, _) (a', _, _) | a /= a' = False
+overlaps (_, o, w) (_, o', w') =
+ let s = o - w
+ s' = o' - w'
+ in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK
+
+lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
+-- Variables are dead across calls, so invalidating all mappings is justified
+lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
+
+assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
+assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
+
+assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
+assignmentRewrite = mkFRewrite3 first middle last
+ where
+ first _ _ = return Nothing
+ middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
+ middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m
+ middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u
+ last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
+ -- Tuple is (inline?, reloads)
+ precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
+ where f (i, l) r = case lookupUFM assign r of
+ Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
+ Just (AlwaysInline _) -> (True, l)
+ Just NeverOptimize -> (i, l)
+ -- This case can show up when we have
+ -- limited optimization fuel.
+ Nothing -> (i, l)
+ rewrite _ (False, []) _ _ = Nothing
+ -- Note [CmmCall Inline Hack]
+ -- Conservative hack: don't do any inlining on what will
+ -- be translated into an OldCmm CmmCalls, since the code
+ -- produced here tends to be unproblematic and I need to write
+ -- lint passes to ensure that we don't put anything in the
+ -- arguments that could be construed as a global register by
+ -- some later translation pass. (For example, slots will turn
+ -- into dereferences of Sp). See [Register parameter passing].
+ -- ToDo: Fix this up to only bug out if all inlines were for
+ -- CmmExprs with global registers (we can't use the
+ -- straightforward mapExpDeep call, in this case.) ToDo: We miss
+ -- an opportunity here, where all possible inlinings should
+ -- instead be sunk.
+ rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
+ rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
+
+ rewriteLocal _ (False, []) _ _ _ _ = Nothing
+ rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n'
+ where n' = AssignLocal l e' u
+ e' = if i then wrapRecExp (inlineExp assign) e else e
+ -- inlinable check omitted, since we can always inline into
+ -- assignments.
+
+ inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x
+ inline False _ n = n
+ inline True _ n | not (inlinable n) = n -- see [CmmCall Inline Hack]
+ inline True assign n = mapExpDeep (inlineExp assign) n
+
+ inlineExp assign old@(CmmReg (CmmLocal r))
+ = case lookupUFM assign r of
+ Just (AlwaysInline x) -> x
+ _ -> old
+ inlineExp assign old@(CmmRegOff (CmmLocal r) i)
+ = case lookupUFM assign r of
+ Just (AlwaysInline x) ->
+ case x of
+ (CmmRegOff r' i') -> CmmRegOff r' (i + i')
+ _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+ where rep = typeWidth (localRegType r)
+ _ -> old
+ inlineExp _ old = old
+
+ inlinable :: CmmNode e x -> Bool
+ inlinable (CmmCall{}) = False
+ inlinable (CmmForeignCall{}) = False
+ inlinable (CmmUnsafeForeignCall{}) = False
+ inlinable _ = True
+
+rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph
+rewriteAssignments g = do
+ g' <- annotateUsage g
+ g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
+ analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
+ return (modifyGraph eraseRegUsage g'')
---------------------
-- prettyprinting
if isEmptyUniqSet stack then PP.empty
else (ppr_regs "live on stack =" stack)]
-instance Outputable AvailRegs where
- ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
- else ppr_regs "available = all but" s
- ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
- else ppr_regs "available = " s
+-- ToDo: Outputable instance for UsageMap and AssignmentMap
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
- | CmmCall -- A call (forign, native or primitive), with
+ | CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
HintedCmmFormals -- zero or more results
HintedCmmActuals -- zero or more arguments
CmmSafety -- whether to build a continuation
CmmReturnInfo
+ -- Some care is necessary when handling the arguments of these, see
+ -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmBranch BlockId -- branch to another BB in this fn
-- * Regs.h claims that BaseReg should be saved last and loaded first
-- * This might not have been tickled before since BaseReg is callee save
-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h). It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers. We can't (nor want) to do that
+-- here, as we don't have liveness information. And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs = (caller_save, caller_load)
where
#ifdef CALLER_SAVES_Base
callerSaves BaseReg = True
#endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg 1 _) = True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg 2 _) = True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg 3 _) = True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg 4 _) = True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg 5 _) = True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg 6 _) = True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg 7 _) = True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg 8 _) = True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1) = True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2) = True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3) = True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4) = True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1) = True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2) = True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg 1) = True
+#endif
#ifdef CALLER_SAVES_Sp
callerSaves Sp = True
#endif
import Unique
import Outputable
import FastString
+import Pair
\end{code}
%************************************************************************
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
| 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 )
-- 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
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
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
-- ((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'
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)
-- 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
import VarSet
import Var
import TcType
+import Coercion
import Util
import BasicTypes( Activation )
import Outputable
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
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
-- 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
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
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)
expr2 = freeVars expr
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
\end{code}
import CoreSyn
import CoreFVs
import CoreUtils
+import Pair
import Bag
import Literal
import DataCon
import PprCore
import ErrUtils
import SrcLoc
+import Kind
import Type
import TypeRep
import Coercion
import Util
import Control.Monad
import Data.Maybe
+import Data.Traversable (traverse)
\end{code}
%************************************************************************
-- 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)
%************************************************************************
\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
= 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') }
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 }
; 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)
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
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}
%************************************************************************
\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
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
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)
\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....
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') }
-- 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
-------------------
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)
-> 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)
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
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}
%************************************************************************
| 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}
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}
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 =
-- 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}
%************************************************************************
= (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))
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
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 "),
= 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))]
+
import ErrUtils
import DynFlags
import Util
+import Pair
import Outputable
import MonadUtils
import FastString
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
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
-- 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
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)
= 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
-- 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) }
-- 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}
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
| 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)
-- ** 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,
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
= 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
* 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
* (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
----------------------------
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'
-- | 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
mkOpenSubst in_scope pairs = Subst in_scope
(mkVarEnv [(id,e) | (id, e) <- pairs, isId id])
(mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+ (mkVarEnv [(v,co) | (v, Coercion co) <- pairs])
------------------------------
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
-- | Add the 'Var' to the in-scope set, but do not remove
-- any existing substitutions for it
addInScopeSet :: Subst -> VarSet -> Subst
-addInScopeSet (Subst in_scope ids tvs) vs
- = Subst (in_scope `extendInScopeSetSet` vs) ids tvs
+addInScopeSet (Subst in_scope ids tvs cvs) vs
+ = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
-- | Add the 'Var' to the in-scope set: as a side effect,
-- and remove any existing substitutions for it
extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs) v
+extendInScope (Subst in_scope ids tvs cvs) v
= Subst (in_scope `extendInScopeSet` v)
- (ids `delVarEnv` v) (tvs `delVarEnv` v)
+ (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
-- | Add the 'Var's to the in-scope set: see also 'extendInScope'
extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope ids tvs) vs
+extendInScopeList (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs)
+ (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
-- | Optimized version of 'extendInScopeList' that can be used if you are certain
--- all the things being added are 'Id's and hence none are 'TyVar's
+-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs) vs
+extendInScopeIds (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) tvs
+ (ids `delVarEnvList` vs) tvs cvs
setInScope :: Subst -> InScopeSet -> Subst
-setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs
+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
\end{code}
Pretty printing, for debugging only
\begin{code}
instance Outputable Subst where
- ppr (Subst in_scope ids tvs)
+ ppr (Subst in_scope ids tvs cvs)
= ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
$$ ptext (sLit " IdSubst =") <+> ppr ids
$$ ptext (sLit " TvSubst =") <+> ppr tvs
+ $$ ptext (sLit " CvSubst =") <+> ppr cvs
<> char '>'
\end{code}
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
-- '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])
-> (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
-> 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
%************************************************************************
%* *
- 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}
\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
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
-------------------
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
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]
-- - 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
------------------
substVarSet :: Subst -> VarSet -> VarSet
-substVarSet subst fvs
+substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
-- 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
-- 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
= 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'))
-- or returns Nothing
maybe_substitute subst b r
| Type ty <- r -- let a::* = TYPE ty in <body>
- = ASSERT( isTyCoVar b )
+ = ASSERT( isTyVar b )
Just (extendTvSubst subst b ty)
- | isId b -- let x = e in <body>
+ | Coercion co <- r
+ = ASSERT( isCoVar b )
+ Just (extendCvSubst subst b co)
+
+ | isId b -- let x = e in <body>
, safe_to_inline (idOccInfo b)
, isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt]
, not (isStableUnfolding (idUnfolding b))
----------------------
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))
----------------------
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}
When inlining 'foo' in 'bar' we want the let-binding for 'inner'
to remain visible until Phase 1
+
-- ** 'Expr' construction
mkLets, mkLams,
- mkApps, mkTyApps, mkVarApps,
+ mkApps, mkTyApps, mkCoApps, mkVarApps,
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
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(..),
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}
| 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.
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
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
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
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
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
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 [] = ()
| 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)
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)
import CoreArity
import Id
import IdInfo
-import TcType( tidyType, tidyTyVarBndr )
+import TcType( tidyType, tidyCo, tidyTyVarBndr )
import Var
import VarEnv
import UniqFM
------------ 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') ->
-- 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])
import VarEnv ( mkInScopeSet )
import Bag
import Util
+import Pair
import FastTypes
import FastString
import Outputable
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
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]
------------
-- 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
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 }
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 {
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
-----------
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
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]
-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
-- * Constructing expressions
- mkSCC, mkCoerce, mkCoerceI,
+ mkSCC, mkCoerce,
bindNonRec, needsCaseBinding,
mkAltExpr, mkPiType, mkPiTypes,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
- dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
+ dataConRepInstPat, dataConRepFSInstPat
) where
#include "HsVersions.h"
import PrimOp
import Id
import IdInfo
-import TcType ( isPredTy )
import Type
import Coercion
import TyCon
import FastString
import Maybes
import Util
+import Pair
import Data.Word
import Data.Bits
\end{code}
-- 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 _ _)
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
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
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
%************************************************************************
\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}
\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]
= 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
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]
-- 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
-- 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
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
--
-- 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
-- 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}
%************************************************************************
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
-- ^ 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!
, 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)
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
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
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}
%************************************************************************
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
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)
\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
---------------
-- 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)
| 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
\begin{code}
module ExternalCore where
-
data Module
= Module Mname [Tdef] [Vdefg]
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
#include "HsVersions.h"
import Id
-import IdInfo
-import Var ( EvVar, mkWildCoVar, setTyVarUnique )
+import Var ( EvVar, setTyVarUnique )
import CoreSyn
import CoreUtils ( exprType, needsCaseBinding, bindNonRec )
import TcType ( mkSigmaTy )
import Type
+import Coercion
import TysPrim
import DataCon ( DataCon, dataConWorkId )
+import IdInfo ( vanillaIdInfo, setStrictnessInfo, setArityInfo )
import Demand
import Name
import Outputable
-- 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
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
-- 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
import CoreSyn
import HscTypes
import TyCon
+-- import Class
+-- import TysPrim( eqPredPrimTyCon )
import TypeRep
import Type
import PprExternalCore () -- Instances
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 =
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
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
(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,
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
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
-- 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
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@
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- | isTyCoVar binder = pprKindedTyVarBndr binder
+ | isTyVar binder = pprKindedTyVarBndr binder
| otherwise = pprTypedBinder binder $$
ppIdInfo binder (idInfo binder)
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
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
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))
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
import PrelNames
import TyCon
import Type
-import Unify( dataConCannotMatch )
import SrcLoc
import UniqSet
import Util
+import BasicTypes
import Outputable
import FastString
\end{code}
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit
-get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s)
get_lit _ = Nothing
-mb_neg :: Num a => Maybe b -> a -> a
-mb_neg Nothing v = v
-mb_neg (Just _) v = -v
+mb_neg :: (a -> a) -> Maybe b -> a -> a
+mb_neg _ Nothing v = v
+mb_neg negate (Just _) v = negate v
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
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 #-}
\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
- dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+ dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
DsEvBind(..), AutoScc(..)
) where
import TcType
import Type
+import Coercion
import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
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]
(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
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
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]
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
; 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 $
-- 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).
import StaticFlags
import CostCentre
import Id
-import Var
import VarSet
+import VarEnv
import DataCon
import TysWiredIn
import BasicTypes
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
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
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}
| 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)"))
-- 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 () } }
import TyCon
import Coercion
import TcType
-import Var
import CmmExpr
import CmmUtils
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
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
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
-- 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
mk_integer :: Integer -> DsM HsLit
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger i integer_ty
-mk_rational :: Rational -> DsM HsLit
+mk_rational :: FractionalLit -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
import MkCore
import MkId
import Id
-import Var
import Name
import Literal
import TyCon
\end{code}
-
%************************************************************************
%* *
Rebindable syntax
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)
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) )
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)
import MatchCon
import MatchLit
import Type
+import Coercion
import TysWiredIn
import ListSetOps
import SrcLoc
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
-- 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?
---------
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
---------
-- 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
---------
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
---------
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.
+
import Util ( all2, takeList, zipEqual )
import ListSetOps ( runs )
import Id
-import Var ( Var )
import NameEnv
import SrcLoc
import Outputable
import SrcLoc
import Data.Ratio
import Outputable
+import BasicTypes
import Util
import FastString
\end{code}
dsLit (HsCharPrim c) = return (Lit (MachChar c))
dsLit (HsIntPrim i) = return (Lit (MachInt i))
dsLit (HsWordPrim w) = return (Lit (MachWord w))
-dsLit (HsFloatPrim f) = return (Lit (MachFloat f))
-dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
+dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
+dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar c) = return (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
dsLit (HsInt i) = return (mkIntExpr i)
dsLit (HsRat r ty) = do
- num <- mkIntegerExpr (numerator r)
- denom <- mkIntegerExpr (denominator r)
+ num <- mkIntegerExpr (numerator (fl_value r))
+ denom <- mkIntegerExpr (denominator (fl_value r))
return (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
hsLitKey (HsWordPrim w) = mkMachWord w
hsLitKey (HsCharPrim c) = MachChar c
hsLitKey (HsStringPrim s) = MachStr s
-hsLitKey (HsFloatPrim f) = MachFloat f
-hsLitKey (HsDoublePrim d) = MachDouble d
+hsLitKey (HsFloatPrim f) = MachFloat (fl_value f)
+hsLitKey (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey (HsString s) = MachStr s
hsLitKey l = pprPanic "hsLitKey" (ppr l)
litValKey :: OverLitVal -> Bool -> Literal
litValKey (HsIntegral i) False = MachInt i
litValKey (HsIntegral i) True = MachInt (-i)
-litValKey (HsFractional r) False = MachFloat r
-litValKey (HsFractional r) True = MachFloat (-r)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
\end{code}
(Just _, HsIntegral i) -> Just (-i)
_ -> Nothing
- mb_rat_lit :: Maybe Rational
+ mb_rat_lit :: Maybe FractionalLit
mb_rat_lit = case (mb_neg, val) of
- (Nothing, HsIntegral i) -> Just (fromInteger i)
- (Just _, HsIntegral i) -> Just (fromInteger (-i))
+ (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i))
+ (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
- (Just _, HsFractional f) -> Just (-f)
+ (Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
mb_str_lit :: Maybe FastString
Generics
InstEnv
TyCon
+ Kind
Type
TypeRep
Unify
MonadUtils
OrdList
Outputable
+ Pair
Panic
Pretty
Serialized
import DataCon
import TyCon
import Util
-import Var
import VarSet
import TysPrim
import DynFlags
{-
| trace (showSDoc (
(char ' '
- $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+ $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
$$ pprCoreExpr (deAnnotate rhs)
$$ char ' '
))) False
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, _, _)
| 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)
-- 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)))
-- 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
import Foreign.C
import Foreign ( nullPtr )
import GHC.Exts ( Ptr(..) )
+import GHC.IO.Encoding ( fileSystemEncoding )
+import qualified GHC.Foreign as GHC
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
+-- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
+withFileCString :: FilePath -> (CString -> IO a) -> IO a
+withFileCString = GHC.withCString fileSystemEncoding
+
insertSymbol :: String -> String -> Ptr a -> IO ()
insertSymbol obj_name key symbol
= let str = prefixUnderscore key
- in withCString obj_name $ \c_obj_name ->
- withCString str $ \c_str ->
+ in withFileCString obj_name $ \c_obj_name ->
+ withCAString str $ \c_str ->
c_insertSymbol c_obj_name c_str symbol
lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCString str $ \c_str -> do
+ withCAString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
-- Nothing => success
-- Just err_msg => failure
loadDLL str = do
- maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+ maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
if maybe_errmsg == nullPtr
then return Nothing
else do str <- peekCString maybe_errmsg
loadArchive :: String -> IO ()
loadArchive str = do
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_loadArchive c_str
when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
loadObj :: String -> IO ()
loadObj str = do
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_loadObj c_str
when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
unloadObj :: String -> IO ()
unloadObj str =
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_unloadObj c_str
when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
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
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)
= 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
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
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
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" <>
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
-- 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
-- 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
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
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
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
--------------------
| 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
-- 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
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
cvtOverLit (IntegerL i)
= do { force i; return $ mkHsIntegral i placeHolderType}
cvtOverLit (RationalL r)
- = do { force r; return $ mkHsFractional r placeHolderType}
+ = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
-cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
-cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
+cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
void :: Type.Type
void = placeHolderType
+cvtFractionalLit :: Rational -> FractionalLit
+cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
+
--------------------------------------------------------------------
-- Turning Name back into RdrName
--------------------------------------------------------------------
type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
- = ValBindsIn -- Before renaming
+ = ValBindsIn -- Before renaming RHS; idR is always RdrName
(LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
-- Recursive by default
- | ValBindsOut -- After renaming
+ | ValBindsOut -- After renaming RHS; idR can be Name or Id
[(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
-- in the list may depend on earlier
-- ones.
[LSig Name]
deriving (Data, Typeable)
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind id = Located (HsBind id)
-type HsBind id = HsBindLR id id
+type LHsBind id = LHsBindLR id id
+type LHsBinds id = LHsBindsLR id id
+type HsBind id = HsBindLR id id
-type LHsBindLR idL idR = Located (HsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
+type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR
= -- | FunBind is used for both functions @f x = e@
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)
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}
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]
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}
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
-import HsTypes (PostTcType)
+import BasicTypes ( FractionalLit(..) )
+import HsTypes ( PostTcType )
import Type ( Type )
import Outputable
import FastString
| HsWordPrim Integer -- Unboxed Word
| HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION
-- (overloaded literals are done with HsOverLit)
- | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION
+ | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION
-- (overloaded literals are done with HsOverLit)
- | HsFloatPrim Rational -- Unboxed Float
- | HsDoublePrim Rational -- Unboxed Double
+ | HsFloatPrim FractionalLit -- Unboxed Float
+ | HsDoublePrim FractionalLit -- Unboxed Double
deriving (Data, Typeable)
instance Eq HsLit where
data OverLitVal
= HsIntegral !Integer -- Integer-looking literals;
- | HsFractional !Rational -- Frac-looking literals
+ | HsFractional !FractionalLit -- Frac-looking literals
| HsIsString !FastString -- String-looking literals
deriving (Data, Typeable)
ppr (HsStringPrim s) = pprHsString s <> char '#'
ppr (HsInt i) = integer i
ppr (HsInteger i _) = integer i
- ppr (HsRat f _) = rational f
- ppr (HsFloatPrim f) = rational f <> char '#'
- ppr (HsDoublePrim d) = rational d <> text "##"
+ ppr (HsRat f _) = ppr f
+ ppr (HsFloatPrim f) = ppr f <> char '#'
+ ppr (HsDoublePrim d) = ppr d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsWordPrim w) = integer w <> text "##"
instance Outputable OverLitVal where
ppr (HsIntegral i) = integer i
- ppr (HsFractional f) = rational f
+ ppr (HsFractional f) = ppr f
ppr (HsIsString s) = pprHsString s
\end{code}
isBangHsBind, isLiftedPatBind,
isBangLPat, hsPatNeedsParens,
- isIrrefutableHsPat,
+ isIrrefutableHsPat,
pprParendLPat
) where
-- 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
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,
import RdrName
import Var
import Coercion
-import Type
+import TypeRep
import DataCon
import Name
import NameSet
import BasicTypes
import SrcLoc
import FastString
-import Outputable
import Util
import Bag
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))
-- See RnEnv.lookupSyntaxName
mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
-mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id
mkHsIsString :: FastString -> PostTcType -> HsOverLit id
mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id
mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
hsValBindsImplicits (ValBindsOut binds _)
- = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
+ = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
+hsValBindsImplicits (ValBindsIn binds _)
+ = lhsBindsImplicits binds
+
+lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
+lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet
where
- hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
- hs_bind _ = emptyNameSet
-hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
+ lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat
+ lhs_bind _ = emptyNameSet
lPatImplicits :: LPat Name -> NameSet
lPatImplicits = hs_lpat
-
{-# OPTIONS_GHC -O #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
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
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
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
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
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
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)
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 }
------------------------------------------------------
-- 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
-- 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
= 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
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)
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,
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
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
-- 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 })
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,
) 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
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]
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
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.
-- 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
---------------------
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
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}
import CoreSyn
import CoreFVs
import Class
+import Kind
import TyCon
import DataCon
import Type
-import Coercion
import TcType
import InstEnv
import FamInstEnv
= 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]
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
-- 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
---------------------
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
import TcRnMonad
import TcType
import Type
+import Coercion
import TypeRep
import HscTypes
import Annotations
import DataCon
import TysWiredIn
import TysPrim ( anyTyConOfKind )
-import Var ( Var, TyVar )
import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
import VarEnv
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}
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
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
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)
(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
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}
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
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
import System.FilePath
import System.IO ( stderr, hPutChar )
| Opt_D_dump_raw_cmm
| Opt_D_dump_cmmz
| Opt_D_dump_cmmz_pretty
+ -- All of the cmmz subflags (there are a lot!) Automatically
+ -- enabled if you run -ddump-cmmz
+ | Opt_D_dump_cmmz_cbe
+ | Opt_D_dump_cmmz_proc
+ | Opt_D_dump_cmmz_spills
+ | Opt_D_dump_cmmz_rewrite
+ | Opt_D_dump_cmmz_dead
+ | Opt_D_dump_cmmz_stub
+ | Opt_D_dump_cmmz_sp
+ | Opt_D_dump_cmmz_procmap
+ | Opt_D_dump_cmmz_split
+ | Opt_D_dump_cmmz_lower
+ | Opt_D_dump_cmmz_info
+ | Opt_D_dump_cmmz_cafs
+ -- end cmmz subflags
| Opt_D_dump_cps_cmm
| Opt_D_dump_cvt_cmm
| Opt_D_dump_asm
filesToClean :: IORef [FilePath],
dirsToClean :: IORef (Map FilePath FilePath),
+ -- Names of files which were generated from -ddump-to-file; used to
+ -- track which ones we need to truncate because it's our first run
+ -- through
+ generatedDumps :: IORef (Set FilePath),
+
-- hsc dynamic flags
flags :: [DynFlag],
-- Don't change this without updating extensionFlags:
ways <- readIORef v_Ways
refFilesToClean <- newIORef []
refDirsToClean <- newIORef Map.empty
+ refGeneratedDumps <- newIORef Set.empty
return dflags{
ways = ways,
buildTag = mkBuildTag (filter (not . wayRTSOnly) ways),
rtsBuildTag = mkBuildTag ways,
filesToClean = refFilesToClean,
- dirsToClean = refDirsToClean
+ dirsToClean = refDirsToClean,
+ generatedDumps = refGeneratedDumps
}
-- | The normal 'DynFlags'. Note that they is not suitable for use in this form
-- end of ghc -M values
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
+ generatedDumps = panic "defaultDynFlags: No generatedDumps",
haddockOptions = Nothing,
flags = defaultFlags,
language = Nothing,
, Flag "dylib-install-name" (hasArg setDylibInstallName)
------- Libraries ---------------------------------------------------
- , Flag "L" (Prefix addLibraryPath)
- , Flag "l" (AnySuffix (upd . addOptl))
+ , Flag "L" (Prefix addLibraryPath)
+ , Flag "l" (hasArg (addOptl . ("-l" ++)))
------- Frameworks --------------------------------------------------
-- -framework-path should really be -F ...
, Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm)
, Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz)
, Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty)
+ , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe)
+ , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills)
+ , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc)
+ , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite)
+ , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead)
+ , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub)
+ , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp)
+ , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap)
+ , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split)
+ , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower)
+ , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info)
+ , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs)
, Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats)
, Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm)
, Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm)
-- 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
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})
import System.Exit ( ExitCode(..), exitWith )
import Data.List
+import qualified Data.Set as Set
+import Data.IORef
+import Control.Monad
import System.IO
-- -----------------------------------------------------------------------------
-- otherwise emit to stdout.
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
- = do let mFile = chooseDumpFile dflags dflag
- case mFile of
- -- write the dump to a file
- -- don't add the header in this case, we can see what kind
- -- of dump it is from the filename.
- Just fileName
- -> do handle <- openFile fileName AppendMode
- hPrintDump handle doc
- hClose handle
-
- -- write the dump to stdout
- Nothing
- -> do printDump (mkDumpDoc hdr doc)
+ = do let mFile = chooseDumpFile dflags dflag
+ case mFile of
+ -- write the dump to a file
+ -- don't add the header in this case, we can see what kind
+ -- of dump it is from the filename.
+ Just fileName
+ -> do
+ let gdref = generatedDumps dflags
+ gd <- readIORef gdref
+ let append = Set.member fileName gd
+ mode = if append then AppendMode else WriteMode
+ when (not append) $
+ writeIORef gdref (Set.insert fileName gd)
+ handle <- openFile fileName mode
+ hPrintDump handle doc
+ hClose handle
+
+ -- write the dump to stdout
+ Nothing
+ -> printDump (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
pprParendType, pprTypeApp,
Kind,
PredType,
- ThetaType, pprForAll, pprThetaArrow,
+ ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
-- ** Entities
TyThing(..),
import Coercion ( synTyConResKind )
import TcType hiding( typeKind )
import Id
-import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
-> 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
-> 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
-- * 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(..),
-- 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:]
-- 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)
-- 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
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvTyCons :: TypeEnv -> [TyCon]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
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]
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
import Id
import IdInfo
import TyCon
+import Coercion( pprCoAxiom )
import TcType
-import Var
import Name
import Outputable
import FastString
----------------------------
-- | 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)
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
(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))
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
| 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
| 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
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)
-- 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
= 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
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))
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)
| 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
-- 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
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
#if defined(mingw32_HOST_OS)
-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
-- return the path $(stuff)/lib.
-getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
- buf <- mallocArray len
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then free buf >> return Nothing
- else do s <- peekCString buf
- free buf
- return (Just (rootDir s))
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
rootDir s = case splitFileName $ normalise s of
(d, ghc_exe)
| lower ghc_exe `elem` ["ghc.exe",
where fail = panic ("can't decompose ghc.exe path: " ++ show s)
lower = map toLower
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getBaseDir = return Nothing
#endif
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
import TargetReg
import Platform
+import Config
import Instruction
import PIC
import Reg
import DynFlags
import StaticFlags
import Util
-import Config
import Digraph
import qualified Pretty
-- stack so add the note in:
Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
#endif
-#if !defined(darwin_TARGET_OS)
-- And just because every other compiler does, lets stick in
-- an identifier directive: .ident "GHC x.y.z"
- Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+ Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
-#endif
where
-- Generate "symbol stubs" for all external symbols that might
import DynFlags
import Module
import Ctype
-import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) )
+import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
import Util ( readRational )
import Control.Monad
| ITchar Char
| ITstring FastString
| ITinteger Integer
- | ITrational Rational
+ | ITrational FractionalLit
| ITprimchar Char
| ITprimstring FastString
| ITprimint Integer
| ITprimword Integer
- | ITprimfloat Rational
- | ITprimdouble Rational
+ | ITprimfloat FractionalLit
+ | ITprimdouble FractionalLit
-- Template Haskell extension tokens
| ITopenExpQuote -- [| or [e|
-- readRational can understand negative rationals, exponents, everything.
tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float str = ITrational $! readRational str
-tok_primfloat str = ITprimfloat $! readRational str
-tok_primdouble str = ITprimdouble $! readRational str
+tok_float str = ITrational $! readFractionalLit str
+tok_primfloat str = ITprimfloat $! readFractionalLit str
+tok_primdouble str = ITprimdouble $! readFractionalLit str
+
+readFractionalLit :: String -> FractionalLit
+readFractionalLit str = (FL $! str) $! readRational str
-- -----------------------------------------------------------------------------
-- Layout processing
| '%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
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
eitherTyConKey = mkPreludeTyConUnique 84
-- Super Kinds constructors
-tySuperKindTyConKey, coSuperKindTyConKey :: Unique
+tySuperKindTyConKey :: Unique
tySuperKindTyConKey = mkPreludeTyConUnique 85
-coSuperKindTyConKey = mkPreludeTyConUnique 86
-- Kind constructors
liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
groupWithIdKey = mkPreludeMiscIdUnique 70
dollarIdKey = mkPreludeMiscIdUnique 71
+coercionTokenIdKey :: Unique
+coercionTokenIdKey = mkPreludeMiscIdUnique 72
+
-- Parallel array functions
singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
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]
]
| 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
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,
word32PrimTyCon, word32PrimTy,
int64PrimTyCon, int64PrimTy,
- word64PrimTyCon, word64PrimTy,
+ word64PrimTyCon, word64PrimTy,
+
+ eqPredPrimTyCon, -- ty1 ~ ty2
-- * Any
anyTyCon, anyTyConOfKind, anyTypeOfKind
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
, word32PrimTyCon
, word64PrimTyCon
, anyTyCon
+ , eqPredPrimTyCon
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
(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
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
%************************************************************************
%* *
- 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}
%************************************************************************
%* *
\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
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}
-- 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
, intTyCon
, listTyCon
, parrTyCon
- , unsafeCoercionTyCon
- , symCoercionTyCon
- , transCoercionTyCon
- , leftCoercionTyCon
- , rightCoercionTyCon
- , instCoercionTyCon
]
\end{code}
isPArrFakeCon :: DataCon -> Bool
isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
\end{code}
-
-
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
, 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) $
import TcEnv ( isBrackStage )
import RnEnv
import RnHsDoc ( rnHsDoc )
-import IfaceEnv ( ifaceExportNames )
+import IfaceEnv ( ifaceExportNames )
import LoadIface ( loadSrcInterface )
import TcRnMonad
import TcRnMonad
import RdrName
import PrelNames
-import TypeRep ( funTyConName )
+import TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
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'
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)
-> 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
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}
-----------------
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)
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
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 )
[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
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}
-> (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}
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.
-- (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')
}
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])
-- 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
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}
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}
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
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
-- 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
= -- 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
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)
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
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}
setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
setBinderOcc usage bndr
- | isTyCoVar bndr = bndr
+ | isTyVar bndr = bndr
| isExportedId bndr = case idOccInfo bndr of
NoOccInfo -> bndr
_ -> setIdOccInfo bndr NoOccInfo
import CoreSyn
import CoreUtils
import Type
+import Coercion
import Id
import Name
import VarEnv
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)
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")
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
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
-- 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 =
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
\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)
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)
= 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) }
= 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
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
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}
-> 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)
(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
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
-- 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,
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,
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
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
= 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
, seInScope = init_in_scope
, seFloats = emptyFloats
, seTvSubst = emptyVarEnv
+ , seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
---------------------
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
---------------------
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}
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
-- 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) }
; 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
-- 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
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
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
-- 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
import CoreSyn
import qualified CoreSubst
import PprCore
+import DataCon ( dataConCannotMatch )
import CoreFVs
import CoreUtils
import CoreArity
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}
| CoerceIt -- C `cast` co
OutCoercion -- The coercion simplified
+ -- Invariant: never an identity coercion
SimplCont
| ApplyTo -- C arg
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
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 })
-------------------
countValArgs :: SimplCont -> Int
countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
+countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont
countValArgs _ = 0
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
| 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
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
-> OutId -- The binder (an InId would be fine too)
+ -- (*not* a CoVar)
-> OccInfo -- From the InId
-> OutExpr
-> Unfolding
| 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 {})
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | otherwise
+ | otherwise
= return (mkLams bndrs body)
\end{code}
%* *
%************************************************************************
-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]
; 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
[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)]
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 )
import Data.List ( mapAccumL )
import Outputable
import FastString
+import Pair
\end{code}
-> 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 }
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) }
-- * 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
; 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
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
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
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)
(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
; 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
---------------------------------
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}
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
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
-- 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))
-- 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
-- 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 }
; -- 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
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
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 })
| 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)
| 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) }
= 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
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)
| 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
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(..) )
import Data.List
\end{code}
-
Note [Overall plumbing for rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* After the desugarer:
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
-- 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
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
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
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
import DmdAnal ( both )
import Serialized ( deserializeWithData )
import Util
+import Pair
import UniqSupply
import Outputable
import FastString
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) }
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
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
; 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
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
-- 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
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
-}
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
{ -- 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
-- 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
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
---------------- 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)
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
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
import Type
import TyCon
+import MkId ( coercionTokenId )
import Id
-import Var ( Var )
import IdInfo
import DataCon
import CostCentre ( noCCS )
-- 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
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
(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
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}
#if mingw32_TARGET_OS
import Packages ( isDllName )
-
+import Type ( typePrimRep )
+import TyCon ( PrimRep(..) )
#endif
\end{code}
= 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
import Demand -- All of it
import CoreSyn
import PprCore
+import Coercion ( isCoVarType )
import CoreUtils ( exprIsHNF, exprIsTrivial )
import CoreArity ( exprArity )
import DataCon ( dataConTyCon, dataConRepStrictness )
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}
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)
= (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
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
(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
-- ; 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'))
-- 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
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]
wwExpr :: CoreExpr -> UniqSM CoreExpr
wwExpr e@(Type {}) = return e
+wwExpr e@(Coercion {}) = return e
wwExpr e@(Lit {}) = return e
wwExpr e@(Var {}) = return e
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 )
= 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) }
<- 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
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-mkWWargs may be given a type like (a~b) => <blah>
-Which really means forall (co:a~b). <blah>
-Because the name of the coercion variable, 'co', isn't mentioned in <blah>,
-nested coercion foralls may all use the same variable; and sometimes do
-see Var.mkWildCoVar.
-
-However, when we do a worker/wrapper split, we must not use shadowed names,
+Wen we do a worker/wrapper split, we must not use shadowed names,
else we'll get
- f = /\ co /\co. fw co co
-which is obviously wrong. Actually, the same is true of type variables, which
-can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a).
-But type variables *are* mentioned in <blah>, so we must substitute.
+ f = /\ a /\a. fw a a
+which is obviously wrong. Type variables can can in principle shadow,
+within a type (e.g. forall a. a -> forall a. a->a). But type
+variables *are* mentioned in <blah>, so we must substitute.
That's why we carry the TvSubst through mkWWargs
-- 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
| 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 )
= 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}
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
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)
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}
\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}
-- 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))
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
-- 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')
-- 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}
#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
-- Preserve type synonyms if possible
-- We can tell if ty' is function-free by
-- whether there are any floated constraints
- ; if isIdentityCoercion co then
- return (ty, ty, emptyCCan)
+ ; if isReflCo co then
+ 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
-- The type function might be *over* saturated
-- in which case the remaining arguments should
-- be dealt with by AppTys
- fam_ty = mkTyConApp tc xi_args
- fam_co = fam_ty -- identity
+ fam_ty = mkTyConApp tc xi_args
; (ret_co, rhs_var, ct) <-
do { is_cached <- lookupFlatCacheMap tc xi_args fl
; case is_cached of
Nothing
| isGivenOrSolved fl ->
do { rhs_var <- newFlattenSkolemTy fam_ty
- ; cv <- newGivenCoVar fam_ty rhs_var fam_co
+ ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
; let ct = CFunEqCan { cc_id = cv
, cc_flavor = fl -- Given
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
- ; let ret_co = mkCoVarCoercion cv
+ ; let ret_co = mkCoVarCo cv
; updateFlatCacheMap tc xi_args rhs_var fl ret_co
; return $ (ret_co, rhs_var, singleCCan ct) }
| otherwise ->
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_var }
- ; let ret_co = mkCoVarCoercion cv
+ ; let ret_co = mkCoVarCo cv
; updateFlatCacheMap tc xi_args rhs_var fl ret_co
; return $ (ret_co, rhs_var, singleCCan ct) } }
; return ( foldl AppTy rhs_var xi_rest
- , foldl AppTy (mkSymCoercion ret_co
- `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest
+ , foldl AppCo (mkSymCo ret_co
+ `mkTransCo` mkTyConAppCo tc cos_args)
+ cos_rest
, ccs `andCCan` ct) }
-
flatten ctxt (PredTy pred)
= do { (pred', co, ccs) <- flattenPred ctxt pred
; return (PredTy pred', co, ccs) }
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}
%************************************************************************
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 = all isIdentityCoercion cos
- dict_co = mkTyConCoercion (classTyCon cn) cos
+ ; let no_flattening_happened = all isReflCo cos
+ dict_co = mkTyConAppCo (classTyCon cn) cos
; v_new <- if no_flattening_happened then return v
else if isGivenOrSolved 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 (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co))
+ ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
-- NB: No more setting evidence for derived now
; return v' }
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,
; 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 isGivenOrSolved 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) <-
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 isGivenOrSolved 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) }
; 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
<- if isWanted fl then
do { argsv <- zipWithM newCoVar tys1 tys2
; setCoBind cv $
- mkTyConCoercion tc1 (map mkCoVarCoercion argsv)
- ; return argsv }
-
- else if isGivenOrSolved fl then
- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv)
+ mkTyConAppCo tc1 (map mkCoVarCo argsv)
+ ; return argsv }
+ else if isGivenOrSolved fl then
+ let cos = decomposeCo (length tys1) (mkCoVarCo cv)
in zipWith3M newGivenCoVar tys1 tys2 cos
else -- Derived
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 isGivenOrSolved 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,
| 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 isGivenOrSolved 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 }
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
- no_flattening_happened = all isIdentityCoercion (co2:cos1)
+ no_flattening_happened = all isReflCo (co2:cos1)
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
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
; case mxi2' of {
Nothing -> canEqFailure fl cv ;
Just xi2' ->
- do { let no_flattening_happened = isIdentityCoercion co
+ do { let no_flattening_happened = isReflCo co
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved 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')
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
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') }
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
; 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
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)])
-- 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
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))
import TypeRep
import Type( isTyVarTy )
import Unify ( tcMatchTys )
-
import Inst
import InstEnv
-
import TyCon
import Name
import NameEnv
-import Id ( idType )
+import Id ( idType, evVarPred )
import Var
import VarSet
import VarEnv
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)
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
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])]
; 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)
; (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
; (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
; (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)
-- 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}
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),
; 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}
-- 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)
; (_, 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
-- 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
; 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
; 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
; 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
; 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
; 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
; 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 _ _) _
; 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) }
; (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) }
----------------
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
; 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}
; 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") ]
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" $
import TysPrim
import TysWiredIn
import Type
-import Var( TyVar )
import TypeRep
import VarSet
import State
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']
-----------------------------------------------------------------------
import PrelNames
import TcType
import TcMType
+import Coercion
import TysPrim
import TysWiredIn
import DataCon
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}
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
- | otherwise = shortCutLit (HsFractional (fromInteger i)) ty
+ | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
-- so we'll call shortCutIntLit, but of course it's a float
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') }
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}
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)
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}
[(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',
-- 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
; 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
-- 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}
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 )
| 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
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}
; 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
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)
----------------
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
, 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}
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
- -- DV: No special care should be taken for Given/Solveds, we will
- -- never encounter a Given entering the constraint bag after a Given/Solved
- = 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}
]
; 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
, cc_flavor = mkSolvedFlavor wd UnkSkol
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 (isGivenOrSolved fl1 && isGivenOrSolved fl2))
; 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)
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
-- 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
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 }
}
, cc_tyargs = args1, cc_rhs = xi1 })
workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2 })
- | tc1 == tc2 && and (zipWith tcEqType args1 args2)
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
, Just GivenSolved <- isGiven_maybe fl1
= mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
- | tc1 == tc2 && and (zipWith tcEqType args1 args2)
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
, Just GivenSolved <- isGiven_maybe fl2
= mkIRStopK "Funeq/Funeq" emptyWorkList
| 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
-- 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
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
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 ()
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:
= 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' }
= 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' }
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 ()
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
; 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,
-- 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
; case fl of
Wanted {} -> do { cv' <- newCoVar rhs_ty xi
- ; setCoBind cv $
- coe `mkTransCoercion` mkCoVarCoercion cv'
+ ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv'
; can_cts <- mkCanonical fl cv'
; let solved = workItem { cc_flavor = solved_fl }
solved_fl = mkSolvedFlavor fl UnkSkol
, tir_new_inert = ContinueWith solved }
}
Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $
- mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe
+ mkSymCo (mkCoVarCo cv) `mkTransCo` coe
; can_cts <- mkCanonical fl cv'
; return $
SomeTopInt { tir_new_work = can_cts
MatchInstSingle (_,_)
| given_overlap untch ->
do { traceTcS "Delaying instance application" $
- vcat [ text "Workitem=" <+> pprPred (ClassP clas tys)
+ vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
, text "Silents and their superclasses=" <+> ppr silents_and_their_scs
, text "All given dictionaries=" <+> ppr all_given_dicts ]
; return NoInstance -- see Note [Instance and Given overlap]
does_not_originate_in_a_silent clas sys
-- UGLY: See Note [Silent parameters overlapping]
- = null $ filter (tcEqPred (ClassP clas sys)) silents_and_their_scs
+ = null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
silents_and_their_scs
= foldlBag (\acc rvnt -> case rvnt of
--------------------------------
-- Creating new evidence variables
newEvVar, newCoVar, newEvVars,
- writeWantedCoVar, readWantedCoVar,
newIP, newDict, newSilentGiven, isSilentEvVar,
newWantedEvVar, newWantedEvVars,
-- 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,
import TypeRep
import TcType
import Type
-import Coercion
import Class
import TyCon
import Var
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
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
= 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;
-- 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
; 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}
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 ()
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}
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
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")
import Id
import TyCon
import TysPrim
-import Coercion ( isIdentityCoI, mkSymCoI )
+import Coercion ( isReflCo, mkSymCo )
import Outputable
import Util
import SrcLoc
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}
%************************************************************************
= 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
-- 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 }] }
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]
%************************************************************************
\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)
--
| 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
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
-- 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 $
-- 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
; 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) }
------------------------
; 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]
= 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]
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'
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')
} }
----------------------------
-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
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
; 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
import NameEnv
import NameSet
import TyCon
-import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
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
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
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)
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
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)
eqSynRhs SynFamilyTyCon SynFamilyTyCon
= True
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
- = tcEqTypeX env t1 t2
+ = eqTypeX env t1 t2
eqSynRhs _ _ = False
in
equalLength tvs1 tvs2 &&
| 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
&& 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
-- 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) } ;
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]
= 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
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
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
CtOrigin(..), EqOrigin(..),
WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
- SkolemInfo(..),
+ SkolemInfo(..),
CtFlavor(..), pprFlavorArising, isWanted,
isGivenOrSolved, isGiven_maybe,
import HsSyn
import HscTypes
import Type
+import Id ( evVarPred )
import Class ( Class )
import DataCon ( DataCon, dataConUserType )
import TcType
-- 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}
%************************************************************************
%* *
Wanted constraints
-
These are forced to be in TcRnTypes because
TcLclEnv mentions WantedConstraints
WantedConstraint mentions CtLoc
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
import TcExpr
import TcEnv
import Id
-import Var ( Var )
import Name
import VarSet
import SrcLoc
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
+import Kind
import TcType
import DynFlags
import Bag
import MonadUtils
import VarSet
+import Pair
import FastString
import HsBinds -- for TcEvBinds stuff
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}
newtype FunEqHead = FunEqHead (TyCon,[Xi])
instance Eq FunEqHead where
- FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && tcEqTypes xis1 xis2
+ FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
instance Ord FunEqHead where
FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2)
= case compare tc1 tc2 of
- EQ -> tcCmpTypes xis1 xis2
+ EQ -> cmpTypes xis1 xis2
other -> other
type TcsUntouchables = (Untouchables,TcTyVarSet)
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
\begin{code}
module TcSimplify(
simplifyInfer,
- simplifyDefault, simplifyDeriv,
+ simplifyDefault, simplifyDeriv,
simplifyRule, simplifyTop, simplifyInteractive
) where
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
; 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)])
import Outputable
import Util ( dropList )
import Data.List ( mapAccumL )
+import Pair
import Unique
import Data.Maybe
import BasicTypes
_ -> 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))
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
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
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)
reifyType :: TypeRep.Type -> TcM TH.Type
-- Monadic only because of failure
reifyType ty@(ForAllTy _ _) = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
+ tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
+ checkValidTyCon, dataDeclChecks, badFamInstDecl
) where
#include "HsVersions.h"
%************************************************************************
%* *
- Type checking family instances
-%* *
-%************************************************************************
-
-Family instances are somewhat of a hybrid. They are processed together with
-class instance heads, but can contain data constructors and hence they share a
-lot of kinding and type checking code with ordinary algebraic data types (and
-GADTs).
-
-\begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
-tcFamInstDecl top_lvl (L loc decl)
- = -- Prime error recovery, set source location
- setSrcSpan loc $
- tcAddDeclCtxt decl $
- do { -- type family instances require -XTypeFamilies
- -- and can't (currently) be in an hs-boot file
- ; type_families <- xoptM Opt_TypeFamilies
- ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
- ; checkTc type_families $ badFamInstDecl (tcdLName decl)
- ; checkTc (not is_boot) $ badBootFamInstDeclErr
-
- -- Perform kind and type checking
- ; tc <- tcFamInstDecl1 decl
- ; checkValidTyCon tc -- Remember to check validity;
- -- no recursion to worry about here
-
- -- Check that toplevel type instances are not for associated types.
- ; when (isTopLevel top_lvl && isAssocFamily tc)
- (addErr $ assocInClassErr (tcdName decl))
-
- ; return (ATyCon tc) }
-
-isAssocFamily :: TyCon -> Bool -- Is an assocaited type
-isAssocFamily tycon
- = case tyConFamInst_maybe tycon of
- Nothing -> panic "isAssocFamily: no family?!?"
- Just (fam, _) -> isTyConAssoc fam
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name
- = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
- ptext (sLit "must be inside a class instance")
-
-
-
-tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
-
- -- "type instance"
-tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
- do { -- check that the family declaration is for a synonym
- checkTc (isFamilyTyCon family) (notFamily family)
- ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
-
- ; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
- -- ToDo: the ExpKind could be better
-
- -- we need the exact same number of type parameters as the family
- -- declaration
- ; let famArity = tyConArity family
- ; checkTc (length k_typats == famArity) $
- wrongNumberOfParmsErr famArity
-
- -- (2) type check type equation
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; t_typats <- mapM tcHsKindedType k_typats
- ; t_rhs <- tcHsKindedType k_rhs
-
- -- (3) check the well-formedness of the instance
- ; checkValidTypeInst t_typats t_rhs
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
- ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
- (typeKind t_rhs)
- NoParentTyCon (Just (family, t_typats))
- }}
-
- -- "newtype instance" and "data instance"
-tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
- tcdCons = cons})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
- do { -- check that the family declaration is for the right kind
- checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
- ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
-
- ; -- (1) kind check the data declaration as usual
- ; k_decl <- kcDataDecl decl k_tvs
- ; let k_ctxt = tcdCtxt k_decl
- k_cons = tcdCons k_decl
-
- -- result kind must be '*' (otherwise, we have too few patterns)
- ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
-
- -- (2) type check indexed data type declaration
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; unbox_strict <- doptM Opt_UnboxStrictFields
-
- -- kind check the type indexes and the context
- ; t_typats <- mapM tcHsKindedType k_typats
- ; stupid_theta <- tcHsKindedContext k_ctxt
-
- -- (3) Check that
- -- (a) left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though, and we checked for
- -- foralls earlier)
- ; mapM_ checkTyFamFreeness t_typats
-
- -- Check that we don't use GADT syntax in H98 world
- ; gadt_ok <- xoptM Opt_GADTs
- ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-
- -- (b) a newtype has exactly one constructor
- ; checkTc (new_or_data == DataType || isSingleton k_cons) $
- newtypeConError tc_name (length k_cons)
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
- ; let ex_ok = True -- Existentials ok for type families!
- ; fixM (\ rep_tycon -> do
- { let orig_res_ty = mkTyConApp fam_tycon t_typats
- ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
- (t_tvs, orig_res_ty) k_cons
- ; tc_rhs <-
- case new_or_data of
- DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( not (null data_cons) )
- mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
- ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
- -- We always assume that indexed types are recursive. Why?
- -- (1) Due to their open nature, we can never be sure that a
- -- further instance might not introduce a new recursive
- -- dependency. (2) They are always valid loop breakers as
- -- they involve a coercion.
- })
- }}
- where
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- _ -> True
-
-tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
-
--- Kind checking of indexed types
--- -
-
--- Kind check type patterns and kind annotate the embedded type variables.
---
--- * Here we check that a type instance matches its kind signature, but we do
--- not check whether there is a pattern for each type index; the latter
--- check is only required for type synonym instances.
-
-kcIdxTyPats :: TyClDecl Name
- -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
- -- ^^kinded tvs ^^kinded ty pats ^^res kind
- -> TcM a
-kcIdxTyPats decl thing_inside
- = kcHsTyVars (tcdTyVars decl) $ \tvs ->
- do { let tc_name = tcdLName decl
- ; fam_tycon <- tcLookupLocatedTyCon tc_name
- ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
- ; hs_typats = fromJust $ tcdTyPats decl }
-
- -- we may not have more parameters than the kind indicates
- ; checkTc (length kinds >= length hs_typats) $
- tooManyParmsErr (tcdLName decl)
-
- -- type functions can have a higher-kinded result
- ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
- ; typats <- zipWithM kcCheckLHsType hs_typats
- [ EK kind (EkArg (ppr tc_name) n)
- | (kind,n) <- kinds `zip` [1..]]
- ; thing_inside tvs typats resultKind fam_tycon
- }
-\end{code}
-
-
-%************************************************************************
-%* *
Kind checking
%* *
%************************************************************************
; stupid_theta <- tcHsKindedContext ctxt
; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; empty_data_decls <- xoptM Opt_EmptyDataDecls
; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs
- ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
- -- Check that we don't use GADT syntax in H98 world
- ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
- -- Check that the stupid theta is empty for a GADT-style declaration
- ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
+ ; dataDeclChecks tc_name new_or_data stupid_theta cons
- -- Check that a newtype has exactly one constructor
- -- Do this before checking for empty data decls, so that
- -- we don't suggest -XEmptyDataDecls for newtypes
- ; checkTc (new_or_data == DataType || isSingleton cons)
- (newtypeConError tc_name (length cons))
-
- -- Check that there's at least one condecl,
- -- or else we're reading an hs-boot file, or -XEmptyDataDecls
- ; checkTc (not (null cons) || empty_data_decls || is_boot)
- (emptyConDeclsErr tc_name)
-
; tycon <- fixM (\ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
; data_cons <- tcConDecls unbox_strict ex_ok
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]
-- 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 ()
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"),
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
--------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
- TcTyVar, TcTyVarSet, TcKind, TcCoVar,
+ TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar,
--------------------------------
-- MetaDetails
---------------------------------
-- 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,
---------------------------------
-- 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
tidyTyVarBndr, tidyFreeTyVars,
tidyOpenTyVar, tidyOpenTyVars,
tidyTopType, tidyPred,
- tidyKind,
+ tidyKind,
+ tidyCo, tidyCos,
---------------------------------
-- Foreign import and export
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
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
-- others:
import DynFlags
-import Name
+import Name hiding (varName)
import NameSet
import VarEnv
import PrelNames
-- 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
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.
\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")
--
-- 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
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}
%************************************************************************
%* *
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
-- 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)
%* *
%************************************************************************
-\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}
, 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 = []
where (tyvars,sc_theta,_,_) = classBigSig cls
\end{code}
-Note [Dictionary-like types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Being "dictionary-like" means either a dictionary type or a tuple thereof.
-In GHC 6.10 we build implication constraints which construct such tuples,
-and if we land up with a binding
- t :: (C [a], Eq [a])
- t = blah
-then we want to treat t as cheap under "-fdicts-cheap" for example.
-(Implication constraints are normally inlined, but sadly not if the
-occurrence is itself inside an INLINE function! Until we revise the
-handling of implication constraints, that is.) This turned out to
-be important in getting good arities in DPH code. Example:
-
- class C a
- class D a where { foo :: a -> a }
- instance C a => D (Maybe a) where { foo x = x }
-
- bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
- {-# INLINE bar #-}
- bar x y = (foo (Just x), foo (Just y))
-
-Then 'bar' should jolly well have arity 4 (two dicts, two args), but
-we ended up with something like
- bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
- in \x,y. <blah>)
-
-This is all a bit ad-hoc; eg it relies on knowing that implication
-constraints build tuples.
-
---------------------- Implicit parameters ---------------------------------
-
-\begin{code}
-mkIPPred :: IPName Name -> Type -> PredType
-mkIPPred ip ty = IParam ip ty
-
-isIPPred :: PredType -> Bool
-isIPPred (IParam _ _) = True
-isIPPred _ = False
-\end{code}
-
---------------------- Equality predicates ---------------------------------
-\begin{code}
-substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)]
-substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty)
- | (tv,ty) <- eq_spec]
-\end{code}
-
%************************************************************************
%* *
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}
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
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.
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}
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
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)
-- 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
import HsSyn
import TypeRep
import CoreUtils( mkPiTypes )
-import TcErrors ( unifyCtxt )
+import TcErrors ( unifyCtxt )
import TcMType
import TcIface
import TcRnMonad
import Name
import ErrUtils
import BasicTypes
-
import Maybes ( allMaybes )
import Util
import Outputable
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)
-- 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'
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)
\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
----------------------
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
= 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
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
----------------------
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 *.
| 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
<- 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
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
\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)
:: [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
; 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"
[ 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
| 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.)
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
-- 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
-- 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 $
(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
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
-> 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
-> SwapFlag
-> TcTyVar -> TcTyVarDetails -- Tyvar 1
-> TcTyVar -> TcTyVarDetails -- Tyvar 2
- -> TcM CoercionI
+ -> TcM Coercion
-- Invarant: The type variables are distinct,
-- Neither is filled in yet
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]
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}
-- 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,
-- ** 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
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
| 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}
%************************************************************************
%* *
%************************************************************************
-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
%************************************************************************
\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
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
import TyCon
import Coercion
import VarSet
-import Var
import Name
import UniqFM
import Outputable
-- 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
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
= 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'
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}
, 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 _ _ = []
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
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!
| 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)
--- /dev/null
+%
+% (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
-%\r
-% (c) The University of Glasgow 2006\r
-%\r
-\r
-\begin{code}\r
-{-# OPTIONS_GHC -w #-}\r
-module OptCoercion (\r
- optCoercion\r
- ) where \r
-\r
-#include "HsVersions.h"\r
-\r
-import Unify ( tcMatchTy )\r
-import Coercion\r
-import Type\r
-import TypeRep\r
-import TyCon\r
-import Var\r
-import VarSet\r
-import VarEnv\r
-import PrelNames\r
-import StaticFlags ( opt_NoOptCoercion )\r
-import Util\r
-import Outputable\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
- Optimising coercions \r
-%* *\r
-%************************************************************************\r
-\r
-Note [Subtle shadowing in coercions]\r
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r
-Supose we optimising a coercion\r
- optCoercion (forall (co_X5:t1~t2). ...co_B1...)\r
-The co_X5 is a wild-card; the bound variable of a coercion for-all\r
-should never appear in the body of the forall. Indeed we often\r
-write it like this\r
- optCoercion ( (t1~t2) => ...co_B1... )\r
-\r
-Just because it's a wild-card doesn't mean we are free to choose\r
-whatever variable we like. For example it'd be wrong for optCoercion\r
-to return\r
- forall (co_B1:t1~t2). ...co_B1...\r
-because now the co_B1 (which is really free) has been captured, and\r
-subsequent substitutions will go wrong. That's why we can't use\r
-mkCoPredTy in the ForAll case, where this note appears. \r
-\r
-\begin{code}\r
-optCoercion :: TvSubst -> Coercion -> NormalCo\r
--- ^ optCoercion applies a substitution to a coercion, \r
--- *and* optimises it to reduce its size\r
-optCoercion env co \r
- | opt_NoOptCoercion = substTy env co\r
- | otherwise = opt_co env False co\r
-\r
-type NormalCo = Coercion\r
- -- Invariants: \r
- -- * The substitution has been fully applied\r
- -- * For trans coercions (co1 `trans` co2)\r
- -- co1 is not a trans, and neither co1 nor co2 is identity\r
- -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)\r
-\r
-type NormalNonIdCo = NormalCo -- Extra invariant: not the identity\r
-\r
-opt_co, opt_co' :: TvSubst\r
- -> Bool -- True <=> return (sym co)\r
- -> Coercion\r
- -> NormalCo \r
-opt_co = opt_co'\r
-\r
-{- Debuggery \r
-opt_co env sym co \r
--- = pprTrace "opt_co {" (ppr sym <+> ppr co) $\r
--- co1 `seq` \r
--- pprTrace "opt_co done }" (ppr co1) \r
--- WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (s1,t1) \r
--- $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) )\r
- = WARN( not (coreEqType co1 simple_result), \r
- (text "env=" <+> ppr env) $$\r
- (text "input=" <+> ppr co) $$\r
- (text "simple=" <+> ppr simple_result) $$\r
- (text "opt=" <+> ppr co1) )\r
- co1\r
- where\r
- co1 = opt_co' env sym co\r
- same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2\r
- (s,t) = coercionKind (substTy env co)\r
- (s1,t1) | sym = (t,s)\r
- | otherwise = (s,t)\r
- (s2,t2) = coercionKind co1\r
-\r
- simple_result | sym = mkSymCoercion (substTy env co)\r
- | otherwise = substTy env co\r
--}\r
-\r
-opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2)\r
-opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2)\r
-opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys))\r
-opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty))\r
-opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co)\r
-\r
-opt_co' env sym co@(TyVarTy tv)\r
- | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty\r
- | not (isCoVar tv) = co -- Identity; does not mention a CoVar\r
- | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto..\r
- | not sym = co\r
- | otherwise = mkSymCoercion co\r
- where\r
- (ty1,ty2) = coVarKind tv\r
-\r
-opt_co' env sym (ForAllTy tv cor) \r
- | isTyVar tv = case substTyVarBndr env tv of\r
- (env', tv') -> ForAllTy tv' (opt_co' env' sym cor)\r
-\r
-opt_co' env sym co@(ForAllTy co_var cor) \r
- | isCoVar co_var \r
- = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co )\r
- ForAllTy co_var' cor'\r
- where\r
- (co1,co2) = coVarKind co_var\r
- co1' = opt_co' env sym co1\r
- co2' = opt_co' env sym co2\r
- cor' = opt_co' env sym cor\r
- co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2'))\r
- -- See Note [Subtle shadowing in coercions]\r
-\r
-opt_co' env sym (TyConApp tc cos)\r
- | Just (arity, desc) <- isCoercionTyCon_maybe tc\r
- = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos))\r
- (map (opt_co env sym) (drop arity cos))\r
- | otherwise\r
- = TyConApp tc (map (opt_co env sym) cos)\r
-\r
---------\r
-opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo\r
--- Used for CoercionTyCons only\r
--- Arguments are *not* already simplified/substituted\r
-opt_co_tc_app env sym tc desc cos\r
- = case desc of\r
- CoAxiom {} -- Do *not* push sym inside top-level axioms\r
- -- e.g. if g is a top-level axiom\r
- -- g a : F a ~ a\r
- -- Then (sym (g ty)) /= g (sym ty) !!\r
- | sym -> mkSymCoercion the_co \r
- | otherwise -> the_co\r
- where\r
- the_co = TyConApp tc (map (opt_co env False) cos)\r
- -- Note that the_co does *not* have sym pushed into it\r
- \r
- CoTrans \r
- | sym -> opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g\r
- | otherwise -> opt_trans opt_co1 opt_co2\r
-\r
- CoUnsafe\r
- | sym -> mkUnsafeCoercion ty2' ty1'\r
- | otherwise -> mkUnsafeCoercion ty1' ty2'\r
-\r
- CoSym -> opt_co env (not sym) co1\r
- CoLeft -> opt_lr fst\r
- CoRight -> opt_lr snd\r
- CoCsel1 -> opt_csel fstOf3\r
- CoCsel2 -> opt_csel sndOf3\r
- CoCselR -> opt_csel thirdOf3\r
-\r
- CoInst -- See if the first arg is already a forall\r
- -- ...then we can just extend the current substitution\r
- | Just (tv, co1_body) <- splitForAllTy_maybe co1\r
- -> opt_co (extendTvSubst env tv ty2') sym co1_body\r
-\r
- -- See if is *now* a forall\r
- | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1\r
- -> substTyWith [tv] [ty2'] opt_co1_body -- An inefficient one-variable substitution\r
-\r
- | otherwise\r
- -> TyConApp tc [opt_co1, ty2']\r
-\r
- where\r
- (co1 : cos1) = cos\r
- (co2 : _) = cos1\r
-\r
- ty1' = substTy env co1\r
- ty2' = substTy env co2\r
-\r
- -- These opt_cos have the sym pushed into them\r
- opt_co1 = opt_co env sym co1\r
- opt_co2 = opt_co env sym co2\r
-\r
- the_unary_opt_co = TyConApp tc [opt_co1]\r
-\r
- opt_lr sel = case splitAppTy_maybe opt_co1 of\r
- Nothing -> the_unary_opt_co \r
- Just lr -> sel lr\r
- opt_csel sel = case splitCoPredTy_maybe opt_co1 of\r
- Nothing -> the_unary_opt_co \r
- Just lr -> sel lr\r
-\r
--------------\r
-opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo]\r
-opt_transL = zipWith opt_trans\r
-\r
-opt_trans :: NormalCo -> NormalCo -> NormalCo\r
-opt_trans co1 co2\r
- | isIdNormCo co1 = co2\r
- | otherwise = opt_trans1 co1 co2\r
-\r
-opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo\r
--- First arg is not the identity\r
-opt_trans1 co1 co2\r
- | isIdNormCo co2 = co1\r
- | otherwise = opt_trans2 co1 co2\r
-\r
-opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo\r
--- Neither arg is the identity\r
-opt_trans2 (TyConApp tc [co1a,co1b]) co2\r
- | tc `hasKey` transCoercionTyConKey\r
- = opt_trans1 co1a (opt_trans2 co1b co2)\r
-\r
-opt_trans2 co1 co2 \r
- | Just co <- opt_trans_rule co1 co2\r
- = co\r
-\r
-opt_trans2 co1 (TyConApp tc [co2a,co2b])\r
- | tc `hasKey` transCoercionTyConKey\r
- , Just co1_2a <- opt_trans_rule co1 co2a\r
- = if isIdNormCo co1_2a\r
- then co2b\r
- else opt_trans2 co1_2a co2b\r
-\r
-opt_trans2 co1 co2\r
- = mkTransCoercion co1 co2\r
-\r
-------\r
-opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo\r
-opt_trans_rule (TyConApp tc1 args1) (TyConApp tc2 args2)\r
- | tc1 == tc2\r
- = case isCoercionTyCon_maybe tc1 of\r
- Nothing \r
- -> Just (TyConApp tc1 (opt_transL args1 args2))\r
- Just (arity, desc) \r
- | arity == length args1\r
- -> opt_trans_rule_equal_tc desc args1 args2\r
- | otherwise\r
- -> case opt_trans_rule_equal_tc desc \r
- (take arity args1) \r
- (take arity args2) of\r
- Just co -> Just $ mkAppTys co $ \r
- opt_transL (drop arity args1) (drop arity args2)\r
- Nothing -> Nothing \r
- \r
--- Push transitivity inside apply\r
-opt_trans_rule co1 co2\r
- | Just (co1a, co1b) <- splitAppTy_maybe co1\r
- , Just (co2a, co2b) <- etaApp_maybe co2\r
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))\r
-\r
- | Just (co2a, co2b) <- splitAppTy_maybe co2\r
- , Just (co1a, co1b) <- etaApp_maybe co1\r
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))\r
-\r
--- Push transitivity inside (s~t)=>r\r
--- We re-use the CoVar rather than using mkCoPredTy\r
--- See Note [Subtle shadowing in coercions]\r
-opt_trans_rule co1 co2\r
- | Just (cv1,r1) <- splitForAllTy_maybe co1\r
- , isCoVar cv1\r
- , Just (s1,t1) <- coVarKind_maybe cv1\r
- , Just (s2,t2,r2) <- etaCoPred_maybe co2\r
- = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))\r
- (opt_trans r1 r2))\r
-\r
- | Just (cv2,r2) <- splitForAllTy_maybe co2\r
- , isCoVar cv2\r
- , Just (s2,t2) <- coVarKind_maybe cv2\r
- , Just (s1,t1,r1) <- etaCoPred_maybe co1\r
- = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))\r
- (opt_trans r1 r2))\r
-\r
--- Push transitivity inside forall\r
-opt_trans_rule co1 co2\r
- | Just (tv1,r1) <- splitTypeForAll_maybe co1\r
- , Just (tv2,r2) <- etaForAll_maybe co2\r
- , let r2' = substTyWith [tv2] [TyVarTy tv1] r2\r
- = Just (ForAllTy tv1 (opt_trans2 r1 r2'))\r
-\r
- | Just (tv2,r2) <- splitTypeForAll_maybe co2\r
- , Just (tv1,r1) <- etaForAll_maybe co1\r
- , let r1' = substTyWith [tv1] [TyVarTy tv2] r1\r
- = Just (ForAllTy tv1 (opt_trans2 r1' r2))\r
-\r
-opt_trans_rule co1 co2\r
-{- Omitting for now, because unsound\r
- | Just (sym1, (ax_tc1, ax1_args, ax_tvs, ax_lhs, ax_rhs)) <- co1_is_axiom_maybe\r
- , Just (sym2, (ax_tc2, ax2_args, _, _, _)) <- co2_is_axiom_maybe\r
- , ax_tc1 == ax_tc2\r
- , sym1 /= sym2\r
- = Just $\r
- if sym1 \r
- then substTyWith ax_tvs (opt_transL (map mkSymCoercion ax1_args) ax2_args) ax_rhs\r
- else substTyWith ax_tvs (opt_transL ax1_args (map mkSymCoercion ax2_args)) ax_lhs\r
--}\r
-\r
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- co1_is_axiom_maybe\r
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co2\r
- = Just $ \r
- if sym \r
- then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args)\r
- else TyConApp ax_tc (opt_transL ax_args cos)\r
-\r
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2\r
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1\r
- = Just $ \r
- if sym \r
- then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos))\r
- else TyConApp ax_tc (opt_transL cos ax_args)\r
- where\r
- co1_is_axiom_maybe = isAxiom_maybe co1\r
- co2_is_axiom_maybe = isAxiom_maybe co2\r
-\r
-opt_trans_rule co1 co2 -- Identity rule\r
- | (ty1,_) <- coercionKind co1\r
- , (_,ty2) <- coercionKind co2\r
- , ty1 `coreEqType` ty2\r
- = Just ty2\r
-\r
-opt_trans_rule _ _ = Nothing\r
-\r
------------ \r
-isAxiom_maybe :: Coercion -> Maybe (Bool, (TyCon, [Coercion], [TyVar], Type, Type))\r
-isAxiom_maybe co\r
- | Just (tc, args) <- splitTyConApp_maybe co\r
- , Just (_, desc) <- isCoercionTyCon_maybe tc\r
- = case desc of\r
- CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs } \r
- -> Just (False, (tc, args, tvs, lhs, rhs))\r
- CoSym | (arg1:_) <- args \r
- -> case isAxiom_maybe arg1 of\r
- Nothing -> Nothing\r
- Just (sym, stuff) -> Just (not sym, stuff)\r
- _ -> Nothing\r
- | otherwise\r
- = Nothing\r
-\r
-matchesAxiomLhs :: [TyVar] -> Type -> Type -> Maybe [Type]\r
-matchesAxiomLhs tvs ty_tmpl ty \r
- = case tcMatchTy (mkVarSet tvs) ty_tmpl ty of\r
- Nothing -> Nothing\r
- Just subst -> Just (map (substTyVar subst) tvs)\r
-\r
------------ \r
-opt_trans_rule_equal_tc :: CoTyConDesc -> [Coercion] -> [Coercion] -> Maybe Coercion\r
--- Rules for Coercion TyCons only\r
-\r
--- Push transitivity inside instantiation\r
-opt_trans_rule_equal_tc desc [co1,ty1] [co2,ty2]\r
- | CoInst <- desc\r
- , ty1 `coreEqType` ty2\r
- , co1 `compatible_co` co2\r
- = Just (mkInstCoercion (opt_trans2 co1 co2) ty1) \r
-\r
-opt_trans_rule_equal_tc desc [co1] [co2]\r
- | CoLeft <- desc, is_compat = Just (mkLeftCoercion res_co)\r
- | CoRight <- desc, is_compat = Just (mkRightCoercion res_co)\r
- | CoCsel1 <- desc, is_compat = Just (mkCsel1Coercion res_co)\r
- | CoCsel2 <- desc, is_compat = Just (mkCsel2Coercion res_co)\r
- | CoCselR <- desc, is_compat = Just (mkCselRCoercion res_co)\r
- where\r
- is_compat = co1 `compatible_co` co2\r
- res_co = opt_trans2 co1 co2\r
-\r
-opt_trans_rule_equal_tc _ _ _ = Nothing\r
-\r
--------------\r
-compatible_co :: Coercion -> Coercion -> Bool\r
--- Check whether (co1 . co2) will be well-kinded\r
-compatible_co co1 co2\r
- = x1 `coreEqType` x2 \r
- where\r
- (_,x1) = coercionKind co1\r
- (x2,_) = coercionKind co2\r
-\r
--------------\r
-etaForAll_maybe :: Coercion -> Maybe (TyVar, Coercion)\r
--- Try to make the coercion be of form (forall tv. co)\r
-etaForAll_maybe co\r
- | Just (tv, r) <- splitForAllTy_maybe co\r
- , not (isCoVar tv) -- Check it is a *type* forall, not a (t1~t2)=>co\r
- = Just (tv, r)\r
-\r
- | (ty1,ty2) <- coercionKind co\r
- , Just (tv1, _) <- splitTypeForAll_maybe ty1\r
- , Just (tv2, _) <- splitTypeForAll_maybe ty2\r
- , tyVarKind tv1 `eqKind` tyVarKind tv2\r
- = Just (tv1, mkInstCoercion co (mkTyVarTy tv1))\r
-\r
- | otherwise\r
- = Nothing\r
-\r
-etaCoPred_maybe :: Coercion -> Maybe (Coercion, Coercion, Coercion)\r
-etaCoPred_maybe co \r
- | Just (s,t,r) <- splitCoPredTy_maybe co\r
- = Just (s,t,r)\r
- \r
- -- co :: (s1~t1)=>r1 ~ (s2~t2)=>r2\r
- | (ty1,ty2) <- coercionKind co -- We know ty1,ty2 have same kind\r
- , Just (s1,_,_) <- splitCoPredTy_maybe ty1\r
- , Just (s2,_,_) <- splitCoPredTy_maybe ty2\r
- , typeKind s1 `eqKind` typeKind s2 -- t1,t2 have same kinds\r
- = Just (mkCsel1Coercion co, mkCsel2Coercion co, mkCselRCoercion co)\r
- \r
- | otherwise\r
- = Nothing\r
-\r
-etaApp_maybe :: Coercion -> Maybe (Coercion, Coercion)\r
--- Split a coercion g :: t1a t1b ~ t2a t2b\r
--- into (left g, right g) if possible\r
-etaApp_maybe co\r
- | Just (co1, co2) <- splitAppTy_maybe co\r
- = Just (co1, co2)\r
-\r
- | (ty1,ty2) <- coercionKind co\r
- , Just (ty1a, _) <- splitAppTy_maybe ty1\r
- , Just (ty2a, _) <- splitAppTy_maybe ty2\r
- , typeKind ty1a `eqKind` typeKind ty2a\r
- = Just (mkLeftCoercion co, mkRightCoercion co)\r
-\r
- | otherwise\r
- = Nothing\r
-\r
--------------\r
-splitTypeForAll_maybe :: Type -> Maybe (TyVar, Type)\r
--- Returns Just only for a *type* forall, not a (t1~t2)=>co\r
-splitTypeForAll_maybe ty\r
- | Just (tv, rty) <- splitForAllTy_maybe ty\r
- , not (isCoVar tv)\r
- = Just (tv, rty)\r
-\r
- | otherwise\r
- = Nothing\r
-\r
--------------\r
-isIdNormCo :: NormalCo -> Bool\r
--- Cheap identity test: look for coercions with no coercion variables at all\r
--- So it'll return False for (sym g `trans` g)\r
-isIdNormCo ty = go ty\r
- where\r
- go (TyVarTy tv) = not (isCoVar tv)\r
- go (AppTy t1 t2) = go t1 && go t2\r
- go (FunTy t1 t2) = go t1 && go t2\r
- go (ForAllTy tv ty) = go (tyVarKind tv) && go ty\r
- go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys\r
- go (PredTy (IParam _ ty)) = go ty\r
- go (PredTy (ClassP _ tys)) = all go tys\r
- go (PredTy (EqPred t1 t2)) = go t1 && go t2\r
-\end{code} \r
+%
+% (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}
AlgTyConRhs(..), visibleDataCons,
TyConParent(..), isNoParent,
SynTyConRhs(..),
- CoTyConDesc(..),
+
+ -- ** Coercion axiom constructors
+ CoAxiom(..), coAxiomName, coAxiomArity,
-- ** Constructing TyCons
mkAlgTyCon,
mkTupleTyCon,
mkSynTyCon,
mkSuperKindTyCon,
- mkCoercionTyCon,
mkForeignTyCon,
mkAnyTyCon,
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,
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,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
makeTyConAbstract,
- newTyConCo_maybe,
+ newTyConCo, newTyConCo_maybe,
-- * Primitive representations of Types
PrimRep(..),
* 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
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)
* 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
--
-- 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
-- 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
| 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
}
-- 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
-- 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:
-- | 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]
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
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,
-- | 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
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?
-- 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!
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).
\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
---------------
--- ^ 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}
tyConHasKind :: TyCon -> Bool
tyConHasKind (SuperKindTyCon {}) = False
-tyConHasKind (CoTyCon {}) = False
tyConHasKind _ = True
-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors
-- | 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
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
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)
-- | 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
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)
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}
-- $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,
-- (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,
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
-
- tySuperKind, coSuperKind,
+ tySuperKind,
-- ** Common Kind type constructors
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
-- * 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,
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
import Class
import TyCon
+import TysPrim
-- others
+import BasicTypes ( IPName )
+import Name ( Name )
import StaticFlags
import Util
import Outputable
-- 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),
coreView _ = Nothing
-
-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
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}
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
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)
\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
~~~~~~~~
\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 ..
= 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'
%************************************************************************
%* *
-\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
mkPredTys :: ThetaType -> [Type]
mkPredTys preds = map PredTy preds
-isEqPred :: PredType -> Bool
-isEqPred (EqPred _ _) = True
-isEqPred _ = False
-
predTypeRep :: PredType -> Type
-- ^ Convert a 'PredType' to its representation type. However, it unwraps
-- only the outermost level; for example, the result might be a newtype application
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
- -- Result might be a newtype application, but the consumer will
- -- look through that too if necessary
-predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
+predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2]
-mkFamilyTyConApp :: TyCon -> [Type] -> Type
--- ^ Given a family instance TyCon and its arg types, return the
--- corresponding family type. E.g:
---
--- > data family T a
--- > data instance T (Maybe b) = MkT b
---
--- Where the instance tycon is :RTL, so:
---
--- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
-mkFamilyTyConApp tc tys
- | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
- , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
- = mkTyConApp fam_tc (substTys fam_subst fam_tys)
- | otherwise
- = mkTyConApp tc tys
+splitPredTy_maybe :: Type -> Maybe PredType
+-- Returns Just for predicates only
+splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty'
+splitPredTy_maybe (PredTy p) = Just p
+splitPredTy_maybe _ = Nothing
--- | Pretty prints a 'TyCon', using the family instance in case of a
--- representation tycon. For example:
---
--- > data T [a] = ...
---
--- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
-pprSourceTyCon :: TyCon -> SDoc
-pprSourceTyCon tycon
- | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
- = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
- | otherwise
- = ppr tycon
-
-isDictTy :: Type -> Bool
-isDictTy ty = case splitTyConApp_maybe ty of
- Just (tc, _) -> isClassTyCon tc
- Nothing -> False
+isPredTy :: Type -> Bool
+isPredTy ty = isJust (splitPredTy_maybe ty)
\end{code}
+--------------------- Equality types ---------------------------------
+\begin{code}
+isReflPredTy :: Type -> Bool
+isReflPredTy ty = case splitPredTy_maybe ty of
+ Just (EqPred ty1 ty2) -> ty1 `eqType` ty2
+ _ -> False
+
+splitEqPredTy_maybe :: Type -> Maybe (Type,Type)
+splitEqPredTy_maybe ty = case splitPredTy_maybe ty of
+ Just (EqPred ty1 ty2) -> Just (ty1,ty2)
+ _ -> Nothing
+
+isEqPredTy :: Type -> Bool
+isEqPredTy ty = case splitPredTy_maybe ty of
+ Just (EqPred {}) -> True
+ _ -> False
+
+-- | Creates a type equality predicate
+mkEqPred :: (a, a) -> Pred a
+mkEqPred (ty1, ty2) = EqPred ty1 ty2
+\end{code}
-%************************************************************************
-%* *
- The free variables of a type
-%* *
-%************************************************************************
-
+--------------------- Dictionary types ---------------------------------
\begin{code}
-tyVarsOfType :: Type -> TyVarSet
--- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
-tyVarsOfType (TyVarTy tv) = unitVarSet tv
-tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
-tyVarsOfType (PredTy sty) = tyVarsOfPred sty
-tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
-tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
-tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder
- -- can mention type variables!
- | isTyVar tv = inner_tvs `delVarSet` tv
- | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) )
- inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv)
- where
- inner_tvs = tyVarsOfType ty
+mkClassPred :: Class -> [Type] -> PredType
+mkClassPred clas tys = ClassP clas tys
-tyVarsOfTypes :: [Type] -> TyVarSet
-tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+isDictTy :: Type -> Bool
+isDictTy ty = case splitPredTy_maybe ty of
+ Just p -> isClassPred p
+ Nothing -> False
+
+isTyVarClassPred :: PredType -> Bool
+isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys
+isTyVarClassPred _ = False
+
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _ = Nothing
+
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys _ = panic "getClassPredTys"
+
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (ClassP clas tys)
+
+isDictLikeTy :: Type -> Bool
+-- Note [Dictionary-like types]
+isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
+isDictLikeTy (PredTy p) = isClassPred p
+isDictLikeTy (TyConApp tc tys)
+ | isTupleTyCon tc = all isDictLikeTy tys
+isDictLikeTy _ = False
+\end{code}
-tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (IParam _ ty) = tyVarsOfType ty
-tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
-tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+Note [Dictionary-like types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Being "dictionary-like" means either a dictionary type or a tuple thereof.
+In GHC 6.10 we build implication constraints which construct such tuples,
+and if we land up with a binding
+ t :: (C [a], Eq [a])
+ t = blah
+then we want to treat t as cheap under "-fdicts-cheap" for example.
+(Implication constraints are normally inlined, but sadly not if the
+occurrence is itself inside an INLINE function! Until we revise the
+handling of implication constraints, that is.) This turned out to
+be important in getting good arities in DPH code. Example:
+
+ class C a
+ class D a where { foo :: a -> a }
+ instance C a => D (Maybe a) where { foo x = x }
+
+ bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
+ {-# INLINE bar #-}
+ bar x y = (foo (Just x), foo (Just y))
+
+Then 'bar' should jolly well have arity 4 (two dicts, two args), but
+we ended up with something like
+ bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
+ in \x,y. <blah>)
+
+This is all a bit ad-hoc; eg it relies on knowing that implication
+constraints build tuples.
+
+--------------------- Implicit parameters ---------------------------------
-tyVarsOfTheta :: ThetaType -> TyVarSet
-tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
+\begin{code}
+mkIPPred :: IPName Name -> Type -> PredType
+mkIPPred ip ty = IParam ip ty
\end{code}
-
%************************************************************************
%* *
Size
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}
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}
%************************************************************************
%* *
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
-- 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}
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
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
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
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
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}
%************************************************************************
\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
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
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
-- | 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"
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
-- 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}
%************************************************************************
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]
-- (\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}
----------------------------------------------------
\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"
-- friends:
import Var
+import VarEnv
+import VarSet
import Name
import BasicTypes
import TyCon
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}
----------------------
\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
[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:
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]
-- > 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]
%************************************************************************
%* *
+ 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
%* *
%************************************************************************
data TyThing = AnId Id
| ADataCon DataCon
| ATyCon TyCon
+ | ACoAxiom CoAxiom
| AClass Class
instance Outputable TyThing where
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")
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}
%************************************************************************
%* *
- 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
------------------
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
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
------------------
-- 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 "<pred>")) <> (ppr pred)
-ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ ifPprDebug (ptext (sLit "<pred>")) <> (pprPredTy pred)
+ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
-ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty
+ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty
ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
ppr_type p (FunTy ty1 ty2)
- = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
- maybeParen p FunPrec $
- sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+ = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
where
- ppr_fun_tail (FunTy ty1 ty2)
- | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
- ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+ -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ ppr_fun_tail (FunTy ty1 ty2)
+ | not (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]
+
is_pred (PredTy {}) = True
is_pred _ = False
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
= maybeParen p FunPrec $
- sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+ sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
- -- We need to be extra careful here as equality constraints will occur as
- -- type variables with an equality kind. So, while collecting quantified
- -- variables, we separate the coercion variables out and turn them into
- -- equality predicates.
- split1 tvs (ForAllTy tv ty)
- | not (isCoVar tv) = split1 (tv:tvs) ty
- split1 tvs ty = (reverse tvs, ty)
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
- split2 ps (ForAllTy tv ty)
- | isCoVar tv = split2 (coVarPred tv : ps) ty
split2 ps ty = (reverse ps, ty)
-ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
-ppr_tc_app _ tc []
- = ppr_tc tc
-ppr_tc_app _ tc [ty]
- | tc `hasKey` listTyConKey = brackets (pprType ty)
- | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]")
- | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
- | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
- | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
- | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
- | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
-
-ppr_tc_app p tc tys
- | isTupleTyCon tc && tyConArity tc == length tys
- = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
- | otherwise
- = ppr_type_app p (getName tc) tys
-
-ppr_type_app :: Prec -> Name -> [Type] -> SDoc
--- Used for classes as well as types; that's why it's separate from ppr_tc_app
-ppr_type_app p tc tys
- | is_sym_occ -- Print infix if possible
- , [ty1,ty2] <- tys -- We know nothing of precedence though
- = maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
- pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
- | otherwise
- = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
- 2 (sep (map pprParendType tys)))
- where
- is_sym_occ = isSymOcc (getOccName tc)
-
-ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc
-ppr_tc tc
- = pp_nt_debug <> ppr tc
- where
- pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
- then ptext (sLit "<recnt>")
- else ptext (sLit "<nt>"))
- | otherwise = empty
-
ppr_tvar :: TyVar -> SDoc
ppr_tvar tv -- Note [Infix type variables]
| isSymOcc (getOccName tv) = parens (ppr tv)
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}
See Trac #2766.
+\begin{code}
+pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+pprTcApp _ _ tc [] -- No brackets for SymOcc
+ = pp_nt_debug <> ppr tc
+ where
+ pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
+ then ptext (sLit "<recnt>")
+ else ptext (sLit "<nt>"))
+ | otherwise = empty
+pprTcApp _ pp tc [ty]
+ | tc `hasKey` listTyConKey = brackets (pp TopPrec ty)
+ | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]")
+ | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
+ | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
+ | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
+ | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
+ | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
+pprTcApp p pp tc tys
+ | isTupleTyCon tc && tyConArity tc == length tys
+ = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+ | otherwise
+ = pprTypeNameApp p pp (getName tc) tys
+
+----------------
+pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
+-- The first arg is the tycon, or sometimes class
+-- Print infix if the tycon/class looks like an operator
+pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys
+
+pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
+-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
+pprTypeNameApp p pp tc tys
+ | is_sym_occ -- Print infix if possible
+ , [ty1,ty2] <- tys -- We know nothing of precedence though
+ = maybeParen p FunPrec $
+ sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2]
+ | otherwise
+ = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys)
+ where
+ is_sym_occ = isSymOcc (getOccName tc)
+
+----------------
+pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc
+pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $
+ hang pp_fun 2 (sep pp_tys)
+
+----------------
+pprArrowChain :: Prec -> [SDoc] -> SDoc
+-- pprArrowChain p [a,b,c] generates a -> b -> c
+pprArrowChain _ [] = empty
+pprArrowChain p (arg:args) = maybeParen p FunPrec $
+ sep [arg, sep (map (arrow <+>) args)]
+\end{code}
module TypeRep where
data Type
-data PredType
+data Pred a
data TyThing
+type PredType = Pred Type
type Kind = Type
isCoercionKind :: Kind -> Bool
-- 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(..),
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}
\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
-> [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)
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
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]
-- ~~~~~~~~~~~~~~~~~~~~~
--------------
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
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
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
\end{code}
-
%************************************************************************
%* *
Unification
| 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
--- /dev/null
+
+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
import CoreSyn
import CoreMonad ( CoreM, getHscEnv )
import Type
-import Var
import Id
import OccName
import DynFlags
; 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)
indexBuiltin,
-- * Projections
- selTy,
+ selTy,
selReplicate,
selPick,
selTags,
import Type
import TyCon
import DataCon
-import Var
import Outputable
import Data.Array
import Type
import Name
import Module
-import Var
import Id
import FastString
import Outputable
initBuiltins pkg
= do mapM_ load dph_Orphans
- -- From dph-common:Data.Array.Parallel.Lifted.PArray
- parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
- let [parrayDataCon] = tyConDataCons parrayTyCon
+ -- From dph-common:Data.Array.Parallel.PArray.PData
+ -- PData is a type family that maps an element type onto the type
+ -- we use to hold an array of those elements.
+ pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData")
- pdataTyCon <- externalTyCon dph_PArray (fsLit "PData")
- paClass <- externalClass dph_PArray (fsLit "PA")
+ -- PR is a type class that holds the primitive operators we can
+ -- apply to array data. Its functions take arrays in terms of PData types.
+ prClass <- externalClass dph_PArray_PData (fsLit "PR")
+ let prTyCon = classTyCon prClass
+ [prDataCon] = tyConDataCons prTyCon
+
+
+ -- From dph-common:Data.Array.Parallel.PArray.PRepr
+ preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr")
+ paClass <- externalClass dph_PArray_PRepr (fsLit "PA")
let paTyCon = classTyCon paClass
[paDataCon] = tyConDataCons paTyCon
paPRSel = classSCSelId paClass 0
- preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
- prClass <- externalClass dph_PArray (fsLit "PR")
- let prTyCon = classTyCon prClass
- [prDataCon] = tyConDataCons prTyCon
+ replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD")
+ emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD")
+ packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD")
+ combines <- mapM (externalVar dph_PArray_PRepr)
+ [mkFastString ("combine" ++ show i ++ "PD")
+ | i <- [2..mAX_DPH_COMBINE]]
+
+ let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
+
- closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
+ -- From dph-common:Data.Array.Parallel.PArray.Scalar
+ -- Scalar is the class of scalar values.
+ -- The dictionary contains functions to coerce U.Arrays of scalars
+ -- to and from the PData representation.
+ scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar")
+
+
+ -- From dph-common:Data.Array.Parallel.Lifted.PArray
+ -- A PArray (Parallel Array) holds the array length and some array elements
+ -- represented by the PData type family.
+ parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray")
+ let [parrayDataCon] = tyConDataCons parrayTyCon
+
+ -- From dph-common:Data.Array.Parallel.PArray.Types
+ voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void")
+ voidVar <- externalVar dph_PArray_Types (fsLit "void")
+ fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid")
+ wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap")
+ sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
+
+ -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
+ pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid")
+ punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit")
+
+
+ closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
- -- From dph-common:Data.Array.Parallel.Lifted.Repr
- voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
- wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
-- From dph-common:Data.Array.Parallel.Lifted.Unboxed
sel_tys <- mapM (externalType dph_Unboxed)
sel_els <- mapM mk_elements
[(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
- sum_tcs <- mapM (externalTyCon dph_Repr)
- (numbered "Sum" 2 mAX_DPH_SUM)
let selTys = listArray (2, mAX_DPH_SUM) sel_tys
selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
- voidVar <- externalVar dph_Repr (fsLit "void")
- pvoidVar <- externalVar dph_Repr (fsLit "pvoid")
- fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid")
- punitVar <- externalVar dph_Repr (fsLit "punit")
+
closureVar <- externalVar dph_Closure (fsLit "closure")
applyVar <- externalVar dph_Closure (fsLit "$:")
liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
- replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD")
- emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD")
- packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD")
-
- combines <- mapM (externalVar dph_PArray)
- [mkFastString ("combine" ++ show i ++ "PD")
- | i <- [2..mAX_DPH_COMBINE]]
- let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
- scalarClass <- externalClass dph_PArray (fsLit "Scalar")
scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
- scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
+ scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
scalar_zips <- mapM (externalVar dph_Scalar)
(numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
, liftingContext = liftingContext
}
where
- mods@(Modules {
- dph_PArray = dph_PArray
- , dph_Repr = dph_Repr
- , dph_Closure = dph_Closure
- , dph_Scalar = dph_Scalar
- , dph_Unboxed = dph_Unboxed
- })
+ -- Extract out all the modules we'll use.
+ -- These are the modules from the DPH base library that contain
+ -- the primitive array types and functions that vectorised code uses.
+ mods@(Modules
+ { dph_PArray_Base = dph_PArray_Base
+ , dph_PArray_Scalar = dph_PArray_Scalar
+ , dph_PArray_PRepr = dph_PArray_PRepr
+ , dph_PArray_PData = dph_PArray_PData
+ , dph_PArray_PDataInstances = dph_PArray_PDataInstances
+ , dph_PArray_Types = dph_PArray_Types
+ , dph_Closure = dph_Closure
+ , dph_Scalar = dph_Scalar
+ , dph_Unboxed = dph_Unboxed
+ })
= dph_Modules pkg
load get_mod = dsLoadModule doc mod
-- | Get the names of all buildin instance functions for the PA class.
initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
initBuiltinPAs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA"))
-- | Get the names of all builtin instance functions for the PR class.
initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
initBuiltinPRs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR"))
-- | Get the names of all DPH instance functions for this class.
-- | Ids of the modules that contain our DPH builtins.
data Modules
- = Modules
- { dph_PArray :: Module
- , dph_Repr :: Module
- , dph_Closure :: Module
- , dph_Unboxed :: Module
- , dph_Instances :: Module
- , dph_Combinators :: Module
- , dph_Scalar :: Module
- , dph_Prelude_PArr :: Module
- , dph_Prelude_Int :: Module
- , dph_Prelude_Word8 :: Module
- , dph_Prelude_Double :: Module
- , dph_Prelude_Bool :: Module
- , dph_Prelude_Tuple :: Module
- }
+ = Modules
+ { dph_PArray_Base :: Module
+ , dph_PArray_Scalar :: Module
+ , dph_PArray_ScalarInstances :: Module
+ , dph_PArray_PRepr :: Module
+ , dph_PArray_PReprInstances :: Module
+ , dph_PArray_PData :: Module
+ , dph_PArray_PDataInstances :: Module
+ , dph_PArray_Types :: Module
+
+ , dph_Closure :: Module
+ , dph_Unboxed :: Module
+ , dph_Combinators :: Module
+ , dph_Scalar :: Module
+
+ , dph_Prelude_Int :: Module
+ , dph_Prelude_Word8 :: Module
+ , dph_Prelude_Double :: Module
+ , dph_Prelude_Bool :: Module
+ , dph_Prelude_Tuple :: Module
+ }
-- | The locations of builtins in the current DPH library.
dph_Modules :: PackageId -> Modules
dph_Modules pkg
- = Modules
- { dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
- , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
- , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
- , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
- , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
- , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
- , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
+ = Modules
+ { dph_PArray_Base = mk (fsLit "Data.Array.Parallel.PArray.Base")
+ , dph_PArray_Scalar = mk (fsLit "Data.Array.Parallel.PArray.Scalar")
+ , dph_PArray_ScalarInstances = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances")
+ , dph_PArray_PRepr = mk (fsLit "Data.Array.Parallel.PArray.PRepr")
+ , dph_PArray_PReprInstances = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances")
+ , dph_PArray_PData = mk (fsLit "Data.Array.Parallel.PArray.PData")
+ , dph_PArray_PDataInstances = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances")
+ , dph_PArray_Types = mk (fsLit "Data.Array.Parallel.PArray.Types")
+
+ , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
+ , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
+ , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
+ , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
- , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
- , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
- , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
- , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
- , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
- , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
- }
- where mk = mkModule pkg . mkModuleNameFS
+ , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
+ , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
+ , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
+ , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
+ , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
+ }
+ where mk = mkModule pkg . mkModuleNameFS
--- | Project out ids of modules that contain orphan instances that we need to load.
dph_Orphans :: [Modules -> Module]
-dph_Orphans = [dph_Repr, dph_Instances]
+dph_Orphans
+ = [ dph_PArray_Scalar
+ , dph_PArray_ScalarInstances
+ , dph_PArray_PReprInstances
+ , dph_PArray_PDataInstances
+ , dph_Scalar
+ ]
-> [( Module, FastString -- Maps the original variable to the one in the DPH
, Module, FastString)] -- packages that it should be rewritten to.
preludeVars (Modules { dph_Combinators = _dph_Combinators
- , dph_PArray = _dph_PArray
, dph_Prelude_Int = dph_Prelude_Int
, dph_Prelude_Word8 = dph_Prelude_Word8
, dph_Prelude_Double = dph_Prelude_Double
, dph_Prelude_Bool = dph_Prelude_Bool
- , dph_Prelude_PArr = _dph_Prelude_PArr
})
- -- Functions that work on whole PArrays, defined in GHC.PArr
- = [ {- mk gHC_PARR' (fsLit "mapP") dph_Combinators (fsLit "mapPA")
- , mk gHC_PARR' (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
- , mk gHC_PARR' (fsLit "zipP") dph_Combinators (fsLit "zipPA")
- , mk gHC_PARR' (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
- , mk gHC_PARR' (fsLit "filterP") dph_Combinators (fsLit "filterPA")
- , mk gHC_PARR' (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
- , mk gHC_PARR' (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
- , mk gHC_PARR' (fsLit "!:") dph_Combinators (fsLit "indexPA")
- , mk gHC_PARR' (fsLit "sliceP") dph_Combinators (fsLit "slicePA")
- , mk gHC_PARR' (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
- , mk gHC_PARR' (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
- , mk gHC_PARR' (fsLit "concatP") dph_Combinators (fsLit "concatPA")
- , mk gHC_PARR' (fsLit "+:+") dph_Combinators (fsLit "appPA")
- , mk gHC_PARR' (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
-
+ = [
-- Map scalar functions to versions using closures.
- , -} mk' dph_Prelude_Int "div" "divV"
+ mk' dph_Prelude_Int "div" "divV"
, mk' dph_Prelude_Int "mod" "modV"
, mk' dph_Prelude_Int "sqrt" "sqrtV"
, mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
- -- , mk' dph_Prelude_Int "upToP" "upToPA"
]
++ vars_Ord dph_Prelude_Int
++ vars_Num dph_Prelude_Int
, mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV")
, mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV")
, mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV")
-
-{-
- -- FIXME: temporary
- , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
- , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
- , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
- , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
- , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA")
- , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA")
- , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA")
--} ]
+ ]
where
mk = (,,,)
mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
scalars' = scalars `extendVarSet` var
is_scalar scalars (Cast e _coe) = is_scalar scalars e
is_scalar scalars (Note _ e ) = is_scalar scalars e
- is_scalar _scalars (Type _) = True
+ is_scalar _scalars (Type {}) = True
+ is_scalar _scalars (Coercion {}) = True
-- Result: (<is this binding group scalar>, scalars ++ variables bound in this group)
is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var)
import OccName
import Id
import MkId
-import Var
import NameEnv
import Unique
import MkCore ( mkWildCase )
import TyCon
import Type
+import Kind
import BuildTyCl
import OccName
import Coercion
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)
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)
import TypeRep
import Type
import TyCon
-import Var
import Outputable
import Control.Monad
import Data.List
import CoreSyn
import CoreUtils
import Type
-import Var
import Control.Monad
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)
mkBuiltinCo get_tc
= do
tc <- builtin get_tc
- return $ mkTyConApp tc []
+ return $ mkTyConAppCo tc []
mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
import CoreSyn
import Type
-import Var
import MkCore
import CoreUtils
import TyCon
import CoreUtils
import CoreUnfold
import Type
-import Var
import Id
import BasicTypes( Arity )
import FastString
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
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)
import Vectorise.Utils.PADict
import CoreSyn
import Type
-import Var
import FastString
import Control.Monad
import Vectorise.Type.Type
import CoreSyn
import Type
-import Var
import VarEnv
import Literal
import Id
a short form…). You can get all of these at once
(<emphasis>lots</emphasis> of output) by using
<option>-v5</option>, or most of them with
- <option>-v4</option>. Some of the most useful ones
- are:</para>
+ <option>-v4</option>. You can prevent them from clogging up
+ your standard output by passing <option>-ddump-to-file</option>.
+ Some of the most useful ones are:</para>
<variablelist>
<varlistentry>
<entry>-</entry>
</row>
<row>
+ <entry><option>-ddump-to-file</option></entry>
+ <entry>Dump to files instead of stdout</entry>
+ <entry>dynamic</entry>
+ <entry>-</entry>
+ </row>
+ <row>
<entry><option>-ddump-asm</option></entry>
<entry>Dump assembly</entry>
<entry>dynamic</entry>
</para>
<para>
- In GHC version 6.12 building shared libraries is supported for Linux on
- x86 and x86-64 architectures and there is partial support on Windows (see
- <xref linkend="win32-dlls"/>). The crucial difference in support on
- Windows is that it is not currently possible to build each Haskell
- package as a separate DLL, it is only possible to link an entire Haskell
- program as one massive DLL.
+ In GHC version 6.12 building shared libraries is supported for Linux (on
+ x86 and x86-64 architectures). GHC version 7.0 adds support on Windows
+ (see <xref linkend="win32-dlls"/>), FreeBSD and OpenBSD (x86 and x86-64),
+ Solaris (x86) and Mac OS X (x86 and PowerPC).
</para>
<para>
that it can be linked against shared library versions of Haskell
packages (such as base). The second is when linking, to link against
the shared versions of the packages' libraries rather than the static
- versions. Obviously this requires that the packages were build with
+ versions. Obviously this requires that the packages were built with
shared libraries. On supported platforms GHC comes with shared
libraries for all the core packages, but if you install extra packages
(e.g. with Cabal) then they would also have to be built with shared
In particular Haskell shared libraries <emphasis>must</emphasis> be
made into packages. You cannot freely assign which modules go in which
shared libraries. The Haskell shared libraries must match the package
- boundaries. Most of the conventions GHC expects when using packages are
- described in <xref linkend="building-packages"/>.
- </para>
- <para>
+ boundaries. The reason for this is that
GHC handles references to symbols <emphasis>within</emphasis> the same
shared library (or main executable binary) differently from references
to symbols <emphasis>between</emphasis> different shared libraries. GHC
<literal>-dynamic</literal> in the link step. That means to
statically link the rts all the base libraries into your new shared
library. This would make a very big, but standalone shared library.
- Indeed this is exactly what we must currently do on Windows where
- -dynamic is not yet supported (see <xref linkend="win32-dlls"/>).
On most platforms however that would require all the static libraries
to have been built with <literal>-fPIC</literal> so that the code is
suitable to include into a shared library and we do not do that at the
The details of how this works varies between platforms, in particular
the three major systems: Unix ELF platforms, Windows and Mac OS X.
</para>
+ <sect3 id="finding-shared-libs-unix">
+ <title>Unix</title>
<para>
On Unix there are two mechanisms. Shared libraries can be installed
into standard locations that the dynamic linker knows about. For
<para>
GHC has a <literal>-dynload</literal> linking flag to select the method
that is used to find shared libraries at runtime. There are currently
- three modes:
+ two modes:
<variablelist>
<varlistentry>
<term>sysdep</term>
<listitem>
<para>
A system-dependent mode. This is also the default mode. On Unix
- ELF systems this embeds rpaths into the shared library or
- executable. In particular it uses absolute paths to where the
- shared libraries for the rts and each package can be found.
- This means the program can immediately be run and it will be
- able to find the libraries it needs. However it may not be
- suitable for deployment if the libraries are installed in a
- different location on another machine.
+ ELF systems this embeds
+ <literal>RPATH</literal>/<literal>RUNPATH</literal> entries into the
+ shared library or executable. In particular it uses absolute paths to
+ where the shared libraries for the rts and each package can be found.
+ This means the program can immediately be run and it will be able to
+ find the libraries it needs. However it may not be suitable for
+ deployment if the libraries are installed in a different location on
+ another machine.
</para>
</listitem>
</varlistentry>
</varlistentry>
</variablelist>
To use relative paths for dependent libraries on Linux and Solaris you
- can use the <literal>deploy</literal> mode and pass suitable a -rpath
- flag to the linker:
+ can pass a suitable <literal>-rpath</literal> flag to the linker:
<programlisting>
ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
</programlisting>
executable e.g. <literal>-optl-Wl,-rpath,'$ORIGIN/lib'</literal>.
</para>
<para>
- The standard assumption on Darwin/MacOS X is that dynamic libraries will
+ This relative path technique can be used with either of the two
+ <literal>-dynload</literal> modes, though it makes most sense with the
+ <literal>deploy</literal> mode. The difference is that with the
+ <literal>deploy</literal> mode, the above example will end up with an ELF
+ <literal>RUNPATH</literal> of just <literal>$ORIGIN</literal> while with
+ the <literal>sysdep</literal> mode the <literal>RUNPATH</literal> will be
+ <literal>$ORIGIN</literal> followed by all the library directories of all
+ the packages that the program depends on (e.g. <literal>base</literal>
+ and <literal>rts</literal> packages etc.) which are typically absolute
+ paths. The unix tool <literal>readelf --dynamic</literal> is handy for
+ inspecting the <literal>RPATH</literal>/<literal>RUNPATH</literal>
+ entries in ELF shared libraries and executables.
+ </para>
+ </sect3>
+ <sect3 id="finding-shared-libs-mac">
+ <title>Mac OS X</title>
+ <para>
+ The standard assumption on Darwin/Mac OS X is that dynamic libraries will
be stamped at build time with an "install name", which is the full
ultimate install path of the library file. Any libraries or executables
that subsequently link against it (even if it hasn't been installed yet)
for you. It automatically sets the install name for dynamic libraries to
the absolute path of the ultimate install location.
</para>
+ </sect3>
</sect2>
</sect1>
</title>
<para>
-<emphasis>Making Haskell libraries into DLLs doesn't work on Windows at the
-moment; we hope to re-instate this facility in the future
-(see <xref linkend="using-shared-libs"/>). Note that
-building an entire Haskell application as a single DLL is still supported: it's
- just multi-DLL Haskell programs that don't work. The Windows
- distribution of GHC contains static libraries only.</emphasis></para>
-
-<!--
-<para>
<indexterm><primary>Dynamic link libraries, Win32</primary></indexterm>
<indexterm><primary>DLLs, Win32</primary></indexterm>
On Win32 platforms, the compiler is capable of both producing and using
</para>
<para>
+There are two distinct ways in which DLLs can be used:
+<itemizedlist>
+ <listitem>
+ <para>
+ You can turn each Haskell package into a DLL, so that multiple
+ Haskell executables using the same packages can share the DLL files.
+ (As opposed to linking the libraries statically, which in effect
+ creates a new copy of the RTS and all libraries for each executable
+ produced.)
+ </para>
+ <para>
+ That is the same as the dynamic linking on other platforms, and it
+ is described in <xref linkend="using-shared-libs"/>.
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ You can package up a complete Haskell program as a DLL, to be called
+ by some external (usually non-Haskell) program. This is usually used
+ to implement plugins and the like, and is described below.
+ </para>
+ </listitem>
+</itemizedlist>
+</para>
+
+<!--
+<para>
Until recently, <command>strip</command> didn't work reliably on DLLs, so you
should test your version with care, or make sure you have the latest
binutils. Unfortunately, we don't know exactly which version of binutils
]
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
DLL_IMPORT_RTS extern int prog_argc;
DLL_IMPORT_RTS extern char *prog_name;
+#ifdef mingw32_HOST_OS
+// We need these two from Haskell too
+void getWin32ProgArgv(int *argc, wchar_t **argv[]);
+void setWin32ProgArgv(int argc, wchar_t *argv[]);
+#endif
+
void stackOverflow(void);
void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
Caller-saves regs have to be saved around C-calls made from STG
land, so this file defines CALLER_SAVES_<reg> for each <reg> that
is designated caller-saves in that machine's C calling convention.
+
+ As it stands, the only registers that are ever marked caller saves
+ are the RX, FX, DX and USER registers; as a result, if you
+ decide to caller save a system register (e.g. SP, HP, etc), note that
+ this code path is completely untested! -- EZY
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
SymI_HasProto(stg_asyncReadzh) \
SymI_HasProto(stg_asyncWritezh) \
SymI_HasProto(stg_asyncDoProczh) \
+ SymI_HasProto(getWin32ProgArgv) \
+ SymI_HasProto(setWin32ProgArgv) \
SymI_HasProto(memset) \
SymI_HasProto(inet_ntoa) \
SymI_HasProto(inet_addr) \
// stgFree(oc->image);
// #endif
stgFree(oc->fileName);
+ stgFree(oc->archiveMemberName);
stgFree(oc->symbols);
stgFree(oc->sections);
stgFree(oc);
* Generic ELF functions
*/
-static char *
-findElfSection ( void* objImage, Elf_Word sh_type )
-{
- char* ehdrC = (char*)objImage;
- Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
- Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- char* ptr = NULL;
- int i;
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type
- /* Ignore the section header's string table. */
- && i != ehdr->e_shstrndx
- /* Ignore string tables named .stabstr, as they contain
- debugging info. */
- && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
- ) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
static int
ocVerifyImage_ELF ( ObjectCode* oc )
{
Elf_Sym* stab;
int i, j, nent, nstrtab, nsymtabs;
char* sh_strtab;
- char* strtab;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
ehdrC + shdr[i].sh_offset,
ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
- if (shdr[i].sh_type == SHT_REL) {
- IF_DEBUG(linker,debugBelch("Rel " ));
- } else if (shdr[i].sh_type == SHT_RELA) {
- IF_DEBUG(linker,debugBelch("RelA " ));
- } else {
- IF_DEBUG(linker,debugBelch(" "));
+#define SECTION_INDEX_VALID(ndx) (ndx > SHN_UNDEF && ndx < ehdr->e_shnum)
+
+ switch (shdr[i].sh_type) {
+
+ case SHT_REL:
+ case SHT_RELA:
+ IF_DEBUG(linker,debugBelch( shdr[i].sh_type == SHT_REL ? "Rel " : "RelA "));
+
+ if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+ if (shdr[i].sh_link == SHN_UNDEF)
+ errorBelch("\n%s: relocation section #%d has no symbol table\n"
+ "This object file has probably been fully striped. "
+ "Such files cannot be linked.\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+ else
+ errorBelch("\n%s: relocation section #%d has an invalid link field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_link);
+ return 0;
+ }
+ if (shdr[shdr[i].sh_link].sh_type != SHT_SYMTAB) {
+ errorBelch("\n%s: relocation section #%d does not link to a symbol table\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+ return 0;
+ }
+ if (!SECTION_INDEX_VALID(shdr[i].sh_info)) {
+ errorBelch("\n%s: relocation section #%d has an invalid info field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_info);
+ return 0;
+ }
+
+ break;
+ case SHT_SYMTAB:
+ IF_DEBUG(linker,debugBelch("Sym "));
+
+ if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+ errorBelch("\n%s: symbol table section #%d has an invalid link field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_link);
+ return 0;
+ }
+ if (shdr[shdr[i].sh_link].sh_type != SHT_STRTAB) {
+ errorBelch("\n%s: symbol table section #%d does not link to a string table\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+
+ return 0;
+ }
+ break;
+ case SHT_STRTAB: IF_DEBUG(linker,debugBelch("Str ")); break;
+ default: IF_DEBUG(linker,debugBelch(" ")); break;
}
if (sh_strtab) {
IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
}
}
- IF_DEBUG(linker,debugBelch( "\nString tables" ));
- strtab = NULL;
+ IF_DEBUG(linker,debugBelch( "\nString tables\n" ));
nstrtab = 0;
for (i = 0; i < ehdr->e_shnum; i++) {
if (shdr[i].sh_type == SHT_STRTAB
debugging info. */
&& 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
) {
- IF_DEBUG(linker,debugBelch(" section %d is a normal string table", i ));
- strtab = ehdrC + shdr[i].sh_offset;
+ IF_DEBUG(linker,debugBelch(" section %d is a normal string table\n", i ));
nstrtab++;
}
}
- if (nstrtab != 1) {
- errorBelch("%s: no string tables, or too many", oc->fileName);
- return 0;
+ if (nstrtab == 0) {
+ IF_DEBUG(linker,debugBelch(" no normal string tables (potentially, but not necessarily a problem)\n"));
}
nsymtabs = 0;
- IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
+ IF_DEBUG(linker,debugBelch( "Symbol tables\n" ));
for (i = 0; i < ehdr->e_shnum; i++) {
if (shdr[i].sh_type != SHT_SYMTAB) continue;
IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
}
IF_DEBUG(linker,debugBelch(" " ));
- IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
+ IF_DEBUG(linker,debugBelch("name=%s\n",
+ ehdrC + shdr[shdr[i].sh_link].sh_offset
+ + stab[j].st_name ));
}
}
if (nsymtabs == 0) {
- errorBelch("%s: didn't find any symbol tables", oc->fileName);
- return 0;
+ // Not having a symbol table is not in principle a problem.
+ // When an object file has no symbols then the 'strip' program
+ // typically will remove the symbol table entirely.
+ IF_DEBUG(linker,debugBelch(" no symbol tables (potentially, but not necessarily a problem)\n"));
}
return 1;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
+ char* strtab;
Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
ASSERT(symhash != NULL);
- if (!strtab) {
- errorBelch("%s: no strtab", oc->fileName);
- return 0;
- }
-
k = 0;
for (i = 0; i < ehdr->e_shnum; i++) {
/* Figure out what kind of section it is. Logic derived from
/* copy stuff into this module's object symbol table */
stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
+ strtab = ehdrC + shdr[shdr[i].sh_link].sh_offset;
nent = shdr[i].sh_size / sizeof(Elf_Sym);
oc->n_symbols = nent;
oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
"ocGetNames_ELF(oc->symbols)");
+ //TODO: we ignore local symbols anyway right? So we can use the
+ // shdr[i].sh_info to get the index of the first non-local symbol
+ // ie we should use j = shdr[i].sh_info
for (j = 0; j < nent; j++) {
char isLocal = FALSE; /* avoids uninit-var warning */
relocations appear to be of this form. */
static int
do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
- Elf_Shdr* shdr, int shnum,
- Elf_Sym* stab, char* strtab )
+ Elf_Shdr* shdr, int shnum )
{
int j;
char *symbol;
Elf_Word* targ;
Elf_Rel* rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
+ Elf_Sym* stab;
+ char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
+ int strtab_shndx = shdr[symtab_shndx].sh_link;
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
targ = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx ));
+ IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d and strtab %d\n",
+ target_shndx, symtab_shndx, strtab_shndx ));
/* Skip sections that we're not interested in. */
{
sparc-solaris relocations appear to be of this form. */
static int
do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
- Elf_Shdr* shdr, int shnum,
- Elf_Sym* stab, char* strtab )
+ Elf_Shdr* shdr, int shnum )
{
int j;
char *symbol = NULL;
Elf_Addr targ;
Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
+ Elf_Sym* stab;
+ char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
+ int strtab_shndx = shdr[symtab_shndx].sh_link;
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
targ = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
target_shndx, symtab_shndx ));
static int
ocResolve_ELF ( ObjectCode* oc )
{
- char *strtab;
int shnum, ok;
- Elf_Sym* stab = NULL;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*) ehdrC;
Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
- /* first find "the" symbol table */
- stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- /* also go find the string table */
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (stab == NULL || strtab == NULL) {
- errorBelch("%s: can't find string or symbol table", oc->fileName);
- return 0;
- }
-
/* Process the relocation sections. */
for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
if (shdr[shnum].sh_type == SHT_REL) {
- ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
- shnum, stab, strtab );
+ ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr, shnum );
if (!ok) return ok;
}
else
if (shdr[shnum].sh_type == SHT_RELA) {
- ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
- shnum, stab, strtab );
+ ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr, shnum );
if (!ok) return ok;
}
}
if( i == ehdr->e_shnum )
{
- errorBelch( "This ELF file contains no symtab" );
- return 0;
+ // Not having a symbol table is not in principle a problem.
+ // When an object file has no symbols then the 'strip' program
+ // typically will remove the symbol table entirely.
+ IF_DEBUG(linker, debugBelch( "The ELF file %s contains no symtab\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName ));
+ return 1;
}
if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
char *prog_name = NULL; /* 'basename' of prog_argv[0] */
int rts_argc = 0; /* ditto */
char *rts_argv[MAX_RTS_ARGS];
+#if defined(mingw32_HOST_OS)
+// On Windows, we want to use GetCommandLineW rather than argc/argv,
+// but we need to mutate the command line arguments for withProgName and
+// friends. The System.Environment module achieves that using this bit of
+// shared state:
+int win32_prog_argc = 0;
+wchar_t **win32_prog_argv = NULL;
+#endif
/*
* constants, used later
full_prog_argc = 0;
full_prog_argv = NULL;
}
+
+#if defined(mingw32_HOST_OS)
+void freeWin32ProgArgv (void);
+
+void
+freeWin32ProgArgv (void)
+{
+ int i;
+
+ if (win32_prog_argv != NULL) {
+ for (i = 0; i < win32_prog_argc; i++) {
+ stgFree(win32_prog_argv[i]);
+ }
+ stgFree(win32_prog_argv);
+ }
+
+ win32_prog_argc = 0;
+ win32_prog_argv = NULL;
+}
+
+void
+getWin32ProgArgv(int *argc, wchar_t **argv[])
+{
+ *argc = win32_prog_argc;
+ *argv = win32_prog_argv;
+}
+
+void
+setWin32ProgArgv(int argc, wchar_t *argv[])
+{
+ int i;
+
+ freeWin32ProgArgv();
+
+ win32_prog_argc = argc;
+ if (argv == NULL) {
+ win32_prog_argv = NULL;
+ return;
+ }
+
+ win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *),
+ "setWin32ProgArgv 1");
+ for (i = 0; i < argc; i++) {
+ win32_prog_argv[i] = stgMallocBytes((wcslen(argv[i]) + 1) * sizeof(wchar_t),
+ "setWin32ProgArgv 2");
+ wcscpy(win32_prog_argv[i], argv[i]);
+ }
+ win32_prog_argv[argc] = NULL;
+}
+#endif
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)
{
}
#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
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*/);
}
#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",
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
getExecPath :: IO (Maybe String)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getLibDir :: IO (Maybe String)
getLibDir = return Nothing
getExecPath :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecPath = return Nothing
#endif
projects / ghc-hetmet.git / commitdiff