Commit fdf86568 authored by Simon Peyton Jones's avatar Simon Peyton Jones

This BIG PATCH contains most of the work for the New Coercion Representation

See the paper "Practical aspects of evidence based compilation in System FC"

* Coercion becomes a data type, distinct from Type

* Coercions become value-level things, rather than type-level things,
  (although the value is zero bits wide, like the State token)
  A consequence is that a coerion abstraction increases the arity by 1
  (just like a dictionary abstraction)

* There is a new constructor in CoreExpr, namely Coercion, to inject
  coercions into terms
parent a52ff761
......@@ -18,7 +18,7 @@ module DataCon (
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
dataConEqSpec, eqSpecPreds, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
......@@ -31,7 +31,7 @@ module DataCon (
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
......@@ -41,6 +41,7 @@ module DataCon (
#include "HsVersions.h"
import Type
import Unify
import Coercion
import TyCon
import Class
......@@ -57,7 +58,6 @@ import Module
import qualified Data.Data as Data
import Data.Char
import Data.Word
import Data.List ( partition )
\end{code}
......@@ -256,8 +256,7 @@ data DataCon
-- dcUnivTyVars = [a]
-- dcExTyVars = [x,y]
-- dcEqSpec = [a~(x,y)]
-- dcEqTheta = [x~y]
-- dcDictTheta = [Ord x]
-- dcOtherTheta = [x~y, Ord x]
-- dcOrigArgTys = [a,List b]
-- dcRepTyCon = T
......@@ -265,7 +264,7 @@ data DataCon
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
-- No existentials, no coercions, nothing.
-- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = []
-- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
-- NB 1: newtypes always have a vanilla data con
-- NB 2: a vanilla constructor can still be declared in GADT-style
-- syntax, provided its type looks like the above.
......@@ -300,8 +299,8 @@ data DataCon
-- In GADT form, this is *exactly* what the programmer writes, even if
-- the context constrains only universally quantified variables
-- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
dcEqTheta :: ThetaType, -- The *equational* constraints
dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints
dcOtherTheta :: ThetaType, -- The other constraints in the data con's type
-- *other than* those in the dcEqSpec
dcStupidTheta :: ThetaType, -- The context of the data type declaration
-- data Eq a => T a = ...
......@@ -338,9 +337,9 @@ data DataCon
-- length = 0 (if not a record) or dataConSourceArity.
-- Constructor representation
dcRepArgTys :: [Type], -- Final, representation argument types,
-- after unboxing and flattening,
-- and *including* existential dictionaries
dcRepArgTys :: [Type], -- Final, representation argument types,
-- after unboxing and flattening,
-- and *including* all existential evidence args
dcRepStrictness :: [StrictnessMark],
-- One for each *representation* *value* argument
......@@ -519,8 +518,8 @@ mkDataCon name declared_infix
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec,
dcOtherTheta = theta,
dcStupidTheta = stupid_theta,
dcEqTheta = eq_theta, dcDictTheta = dict_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcRepArgTys = rep_arg_tys,
......@@ -536,10 +535,9 @@ mkDataCon name declared_infix
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
(eq_theta,dict_theta) = partition isEqPred theta
dict_tys = mkPredTys dict_theta
real_arg_tys = dict_tys ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts
full_theta = eqSpecPreds eq_spec ++ theta
real_arg_tys = mkPredTys full_theta ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
......@@ -547,11 +545,6 @@ mkDataCon name declared_infix
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
mkFunTys (mkPredTys eq_theta) $
-- NB: the dict args are already in rep_arg_tys
-- because they might be flattened..
-- but the equality predicates are not
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
......@@ -611,13 +604,10 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
dataConEqSpec :: DataCon -> [(TyVar,Type)]
dataConEqSpec = dcEqSpec
-- | The equational constraints on the data constructor type
dataConEqTheta :: DataCon -> ThetaType
dataConEqTheta = dcEqTheta
-- | The type class and implicit parameter contsraints on the data constructor type
dataConDictTheta :: DataCon -> ThetaType
dataConDictTheta = dcDictTheta
-- | The *full* constraints on the constructor type
dataConTheta :: DataCon -> ThetaType
dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
= eqSpecPreds eq_spec ++ theta
-- | Get the Id of the 'DataCon' worker: a function that is the "actual"
-- constructor and has no top level binding in the program. The type may
......@@ -666,10 +656,10 @@ dataConFieldType con label
dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcStrictMarks
-- | Strictness of /existential/ arguments only
-- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this
dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
dataConExStricts dc = map mk_dict_strict_mark $ (dcOtherTheta dc)
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
......@@ -705,10 +695,10 @@ dataConRepStrictness dc = dcRepStrictness dc
--
-- 4) The /original/ result type of the 'DataCon'
dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcEqTheta = eq_theta, dcDictTheta = dict_theta,
dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty)
= (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
-- | The \"full signature\" of the 'DataCon' returns, in order:
--
......@@ -725,11 +715,11 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_
--
-- 6) The original result type of the 'DataCon'
dataConFullSig :: DataCon
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type)
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcEqTheta = eq_theta, dcDictTheta = dict_theta,
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty)
= (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
dataConOrigResTy :: DataCon -> Type
dataConOrigResTy dc = dcOrigResTy dc
......@@ -754,11 +744,10 @@ dataConUserType :: DataCon -> Type
-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys eq_theta) $
mkFunTys (mkPredTys dict_theta) $
mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
res_ty
......@@ -841,6 +830,24 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
[] -> panic "classDataCon"
\end{code}
\begin{code}
dataConCannotMatch :: [Type] -> DataCon -> Bool
-- Returns True iff the data con *definitely cannot* match a
-- scrutinee of type (T tys)
-- where T is the type constructor for the data con
--
dataConCannotMatch tys con
| null eq_spec = False -- Common
| all isTyVarTy tys = False -- Also common
| otherwise
= typesCantMatch (map (substTyVar subst . fst) eq_spec)
(map snd eq_spec)
where
dc_tvs = dataConUnivTyVars con
eq_spec = dataConEqSpec con
subst = zipTopTvSubst dc_tvs tys
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
......
......@@ -23,7 +23,7 @@
-- * 'Var.Var': see "Var#name_types"
module Id (
-- * The main types
Id, DictId,
Var, Id, isId,
-- ** Simple construction
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
......@@ -34,8 +34,7 @@ module Id (
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
isId, idPrimRep,
recordSelectorFieldLabel,
idPrimRep, recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
......@@ -46,7 +45,8 @@ module Id (
-- ** Predicates on Ids
isImplicitId, isDeadBinder, isDictId, isStrictId,
isImplicitId, isDeadBinder,
isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId, dfunNSilent,
......@@ -57,6 +57,9 @@ module Id (
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
-- ** Evidence variables
DictId, isDictId, isEvVar, evVarPred,
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
......@@ -95,8 +98,8 @@ import IdInfo
import BasicTypes
-- Imported and re-exported
import Var( Var, Id, DictId,
idInfo, idDetails, globaliseId,
import Var( Var, Id, DictId, EvVar,
idInfo, idDetails, globaliseId, varType,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
......@@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
hasNoBinding :: Id -> Bool
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.
......@@ -446,6 +445,26 @@ isTickBoxOp_maybe id =
_ -> Nothing
\end{code}
%************************************************************************
%* *
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}
......
......@@ -10,7 +10,7 @@ Haskell. [WDP 94/11])
\begin{code}
module IdInfo (
-- * The IdDetails type
IdDetails(..), pprIdDetails,
IdDetails(..), pprIdDetails, coVarDetails,
-- * The IdInfo type
IdInfo, -- Abstract
......@@ -141,6 +141,9 @@ data IdDetails
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
coVarDetails :: IdDetails
coVarDetails = VanillaId
instance Outputable IdDetails where
ppr = pprIdDetails
......
......@@ -4,5 +4,7 @@ import Outputable
data IdInfo
data IdDetails
vanillaIdInfo :: IdInfo
coVarDetails :: IdDetails
pprIdDetails :: IdDetails -> SDoc
\end{code}
\ No newline at end of file
......@@ -25,13 +25,18 @@ module MkId (
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId,
-- Re-export error Ids
module PrelRules
) where
#include "HsVersions.h"
import Rules
import TysPrim
import TysWiredIn ( unitTy )
import PrelRules
import Type
import Coercion
......@@ -48,7 +53,7 @@ import PrimOp
import ForeignCall
import DataCon
import Id
import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar )
import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
......@@ -56,6 +61,7 @@ import Unique
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
import Pair
import Outputable
import FastString
import ListSetOps
......@@ -224,7 +230,7 @@ mkDataConIds wrap_name wkr_name data_con
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
theta, orig_arg_tys, res_ty) = dataConFullSig data_con
tycon = dataConTyCon data_con -- The representation TyCon (not family)
----------- Worker (algebraic data types only) --------------
......@@ -287,12 +293,10 @@ mkDataConIds wrap_name wkr_name data_con
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
eq_tys = mkPredTys eq_theta
dict_tys = mkPredTys dict_theta
wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
mkFunTys orig_arg_tys $ res_ty
-- NB: watch out here if you allow user-written equality
-- constraints in data constructor signatures
ev_tys = mkPredTys theta
wrap_ty = mkForAllTys wrap_tvs $
mkFunTys ev_tys $
mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
......@@ -318,32 +322,23 @@ mkDataConIds wrap_name wkr_name data_con
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
wrap_rhs = mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
mkLams ev_args $
mkLams id_args $
foldr mk_case con_app
(zip (dict_args ++ id_args) all_strict_marks)
(zip (ev_args ++ id_args) all_strict_marks)
i3 []
con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
Var wrk_id `mkTyApps` res_ty_args
`mkVarApps` ex_tvs
-- Equality evidence:
`mkTyApps` map snd eq_spec
`mkVarApps` eq_args
`mkCoApps` map (mkReflCo . snd) eq_spec
`mkVarApps` reverse rep_ids
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
wrap_arity = i3-1
(eq_args,_) = mkCoVarLocals i3 eq_tys
mkCoVarLocals i [] = ([],i)
mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
y = mkCoVar (mkSysTvName (mkBuiltinUnique i)
(fsLit "dc_co")) x
in (y:ys,j)
(ev_args,i2) = mkLocals 1 ev_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
wrap_arity = i3-1
mk_case
:: (Id, HsBang) -- Arg, strictness
......@@ -458,7 +453,7 @@ mkDictSelId no_unf name clas
occNameFS (getOccName name)
, ru_fn = name
, ru_nargs = n_ty_args + 1
, ru_try = dictSelRule val_index n_ty_args n_eq_args }
, ru_try = dictSelRule val_index n_ty_args }
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
......@@ -474,8 +469,6 @@ mkDictSelId no_unf name clas
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
eq_theta = dataConEqTheta data_con
n_eq_args = length eq_theta
-- 'index' is a 0-index into the *value* arguments of the dictionary
val_index = assoc "MkId.mkDictSelId" sel_index_prs name
......@@ -485,25 +478,23 @@ mkDictSelId no_unf name clas
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
arg_ids = mkTemplateLocalsNum 2 arg_tys
eq_ids = map mkWildEvBinder eq_theta
rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
[(DataAlt data_con, arg_ids, Var the_arg_id)]
dictSelRule :: Int -> Arity -> Arity
dictSelRule :: Int -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
dictSelRule val_index n_ty_args n_eq_args id_unf args
dictSelRule val_index n_ty_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
, let val_args = drop n_eq_args con_args
= Just (val_args !! val_index)
= Just (con_args !! val_index)
| otherwise
= Nothing
\end{code}
......@@ -628,7 +619,7 @@ mkReboxingAlt us con args rhs
-- Type variable case
go (arg:args) stricts us
| isTyCoVar arg
| isTyVar arg
= let (binds, args') = go args stricts us
in (binds, arg:args')
......@@ -674,13 +665,11 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- coercion constructor of the newtype or applied by itself).
wrapNewTypeBody tycon args result_expr
= wrapFamInstBody tycon args inner
= ASSERT( isNewTyCon tycon )
wrapFamInstBody tycon args $
mkCoerce (mkSymCo co) result_expr
where
inner
| Just co_con <- newTyConCo_maybe tycon
= mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
| otherwise
= result_expr
co = mkAxInstCo (newTyConCo tycon) args
-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker. We have to do it this way as
......@@ -689,10 +678,8 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
| Just co_con <- newTyConCo_maybe tycon
= mkCoerce (mkTyConApp co_con args) result_expr
| otherwise
= result_expr
= ASSERT( isNewTyCon tycon )
mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
......@@ -702,14 +689,14 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body
= mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
| otherwise
= body
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCoerce (mkTyConApp co_con args) scrut
= mkCoerce (mkAxInstCo co_con args) scrut
| otherwise
= scrut
\end{code}
......@@ -858,7 +845,7 @@ mkDictFunTy tvs theta clas tys
(classSCTheta clas)
-- See Note [Silent Superclass Arguments]
discard pred = isEmptyVarSet (tyVarsOfPred pred)
|| any (`tcEqPred` pred) theta
|| any (`eqPred` pred) theta
-- See the DFun Superclass Invariant in TcInstDcls
\end{code}
......@@ -885,12 +872,13 @@ they can unify with both unlifted and lifted types. Hence we provide
another gun with which to shoot yourself in the foot.
\begin{code}
lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
\end{code}
\begin{code}
......@@ -908,7 +896,7 @@ unsafeCoerceId
(mkFunTy argAlphaTy openBetaTy)
[x] = mkTemplateLocals [argAlphaTy]
rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $
Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy)
Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy)
------------------------------------------------
nullAddrId :: Id
......@@ -944,7 +932,7 @@ seqId = pcMiscPrelId seqName ty info
match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
= Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
= Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
scrut, expr])
match_seq_of_cast _ _ = Nothing
......@@ -1054,6 +1042,12 @@ realWorldPrimId -- :: State# RealWorld
voidArgId :: Id
voidArgId -- :: State# RealWorld
= mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
coercionTokenId :: Id -- :: () ~ ()
coercionTokenId -- Used to replace Coercion terms when we go to STG
= pcMiscPrelId coercionTokenName
(mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
noCafIdInfo
\end{code}
......
......@@ -32,7 +32,7 @@
module Var (
-- * The main data type and synonyms
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
......@@ -41,34 +41,25 @@ module Var (
setVarName, setVarUnique, setVarType,
-- ** Constructing, taking apart, modifying 'Id's
mkGlobalVar, mkLocalVar, mkExportedLocalVar,
mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,
idInfo, idDetails,
lazySetIdInfo, setIdDetails, globaliseId,
setIdExported, setIdNotExported,
-- ** Predicates
isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
isId, isTyVar, isTcTyVar,
isLocalVar, isLocalId,
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- ** Constructing 'TyVar's
mkTyVar, mkTcTyVar, mkWildCoVar,
mkTyVar, mkTcTyVar,
-- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind,
-- ** Constructing 'CoVar's
mkCoVar,
-- ** Taking 'CoVar's apart
coVarName,
-- ** Modifying 'CoVar's
setCoVarUnique, setCoVarName
setTyVarName, setTyVarUnique, setTyVarKind
) where
......@@ -77,8 +68,7 @@ module Var (
import {-# SOURCE #-} TypeRep( Type, Kind )