\begin{code}
module MkId (
- mkDictFunId, mkDefaultMethodId,
- mkDictSelId,
+ mkDictFunId, mkDictFunTy, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
-- 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) --------------
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
- `setArityInfo` wkr_arity
+ `setArityInfo` wkr_arity
`setStrictnessInfo` Just wkr_sig
- `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
+ `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
+ `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` newtype_unf
id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
- eq_tys = mkPredTys eq_theta
- dict_tys = mkPredTys dict_theta
- wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
- mkFunTys orig_arg_tys $ res_ty
- -- NB: watch out here if you allow user-written equality
- -- constraints in data constructor signatures
+ ev_tys = mkPredTys other_theta
+ wrap_ty = mkForAllTys wrap_tvs $
+ mkFunTys ev_tys $
+ mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
`setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
+ `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf
`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 = mkInlineRule wrap_rhs (Just (length dict_args + length id_args))
+ 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
base_info = noCafIdInfo
`setArityInfo` 1
- `setStrictnessInfo` Just strict_sig
+ `setStrictnessInfo` Just strict_sig
`setUnfoldingInfo` (if no_unf then noUnfolding
- else mkImplicitUnfolding rhs)
+ else mkImplicitUnfolding rhs)
-- In module where class op is defined, we must add
-- the unfolding, even though it'll never be inlined
-- becuase we use that to generate a top-level binding
-- for the ClassOp
- info = base_info `setSpecInfo` mkSpecInfo [rule]
- `setInlinePragInfo` neverInlinePragma
- -- Add a magic BuiltinRule, and never inline it
- -- so that the rule is always available to fire.
- -- See Note [ClassOp/DFun selection] in TcInstDcls
+ info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
+ -- See Note [Single-method classes] for why alwaysInlinePragma
+ | otherwise = base_info `setSpecInfo` mkSpecInfo [rule]
+ `setInlinePragInfo` neverInlinePragma
+ -- Add a magic BuiltinRule, and never inline it
+ -- so that the rule is always available to fire.
+ -- See Note [ClassOp/DFun selection] in TcInstDcls
n_ty_args = length tyvars
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
--- Oh, very clever
--- sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+-- 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
--
--- NB: the data constructor has the same number of type and
--- coercion args as the selector
---
--- This only works for *value* superclasses
--- There are no selector functions for equality superclasses
-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}
that they aren't discarded by the occurrence analyser.
\begin{code}
-mkDefaultMethodId :: Id -- Selector Id
- -> Name -- Default method name
- -> Id -- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
-> ThetaType
-> Class
-> [Type]
-> Id
+-- Implements the DFun Superclass Invariant (see TcInstDcls)
-mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
- = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo
+mkDictFunId dfun_name tvs theta clas tys
+ = mkExportedLocalVar (DFunId n_silent is_nt)
+ dfun_name
+ dfun_ty
+ vanillaIdInfo
where
is_nt = isNewTyCon (classTyCon clas)
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
+ (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
+
+mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
+mkDictFunTy tvs theta clas tys
+ = (length silent_theta, dfun_ty)
+ where
+ dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkDictTy clas tys)
+ silent_theta = filterOut discard $
+ substTheta (zipTopTvSubst (classTyVars clas) tys)
+ (classSCTheta clas)
+ -- See Note [Silent Superclass Arguments]
+ discard pred = isEmptyVarSet (tyVarsOfPred pred)
+ || 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}
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
where
- info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [argAlphaTyVar,openBetaTyVar]
(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
-- a way to write this literal in Haskell.
nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
- info = noCafIdInfo `setUnfoldingInfo`
- mkCompulsoryUnfolding (Lit nullAddrLit)
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit)
------------------------------------------------
seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
- info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
- `setSpecInfo` mkSpecInfo [seq_cast_rule]
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ `setSpecInfo` mkSpecInfo [seq_cast_rule]
ty = mkForAllTys [alphaTyVar,argBetaTyVar]
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}