\begin{code}
module MkId (
- mkDictFunId, mkDefaultMethodId,
- mkDictSelId,
+ mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
- unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
- lazyId, lazyIdKey,
-
- mkRuntimeErrorApp, mkImpossibleExpr,
- rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
- nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
- pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
-
- unsafeCoerceName
+ unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
+ voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
) where
#include "HsVersions.h"
import Rules
import TysPrim
-import TysWiredIn
import PrelRules
import Type
import Coercion
import TcType
+import MkCore
import CoreUtils ( exprType, mkCoerce )
import CoreUnfold
import Literal
\begin{code}
wiredInIds :: [Id]
wiredInIds
- = [
-
- eRROR_ID, -- This one isn't used anywhere else in the compiler
- -- But we still need it in wiredInIds so that when GHC
- -- compiles a program that mentions 'error' we don't
- -- import its type from the interface file; we just get
- -- the Id defined here. Which has an 'open-tyvar' type.
-
- rUNTIME_ERROR_ID,
- iRREFUT_PAT_ERROR_ID,
- nON_EXHAUSTIVE_GUARDS_ERROR_ID,
- nO_METHOD_BINDING_ERROR_ID,
- pAT_ERROR_ID,
- rEC_CON_ERROR_ID,
- rEC_SEL_ERROR_ID,
-
- lazyId
- ] ++ ghcPrimIds
+ = [lazyId]
+ ++ errorIds -- Defined in MkCore
+ ++ ghcPrimIds
-- These Ids are exported from GHC.Prim
ghcPrimIds :: [Id]
`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
-- ...(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 dict_args + length id_args)) wrap_rhs
wrap_rhs = mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
mkCoVarLocals i [] = ([],i)
mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
- y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
+ y = mkCoVar (mkSysTvName (mkBuiltinUnique i)
+ (fsLit "dc_co")) x
in (y:ys,j)
mk_case
recover the original type signature from the class op selector.
\begin{code}
-mkDictSelId :: Bool -- True <=> don't include the unfolding
- -- Little point on imports without -O, because the
- -- dictionary itself won't be visible
- -> Name -> Class -> Id
+mkDictSelId :: Bool -- True <=> don't include the unfolding
+ -- Little point on imports without -O, because the
+ -- dictionary itself won't be visible
+ -> Name -- Name of one of the *value* selectors
+ -- (dictionary superclass or method)
+ -> Class -> Id
mkDictSelId no_unf name clas
= mkGlobalId (ClassOpId clas) name sel_ty info
where
occNameFS (getOccName name)
, ru_fn = name
, ru_nargs = n_ty_args + 1
- , ru_try = dictSelRule index n_ty_args }
+ , ru_try = dictSelRule val_index n_ty_args n_eq_args }
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
| otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
| id <- arg_ids ])
- tycon = classTyCon clas
- new_tycon = isNewTyCon tycon
- [data_con] = tyConDataCons tycon
- tyvars = dataConUnivTyVars data_con
- arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
- eq_theta = dataConEqTheta data_con
- index = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name
- the_arg_id = arg_ids !! index
+ tycon = classTyCon clas
+ new_tycon = isNewTyCon tycon
+ [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
- pred = mkClassPred clas (mkTyVarTys tyvars)
- dict_id = mkTemplateLocal 1 $ mkPredTy pred
- (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta
- arg_ids = mkTemplateLocalsNum n arg_tys
+ -- 'index' is a 0-index into the *value* arguments of the dictionary
+ val_index = assoc "MkId.mkDictSelId" sel_index_prs name
+ sel_index_prs = map idName (classAllSelIds clas) `zip` [0..]
- 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)
+ the_arg_id = arg_ids !! val_index
+ 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)]
-dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
--- Oh, very clever
--- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
--- op_i t1..tk (D t1..tk op1 ... opm) = opi
+dictSelRule :: Int -> Arity -> 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
--
--- NB: the data constructor has the same number of type args as the class op
-
-dictSelRule index n_ty_args id_unf args
+dictSelRule val_index n_ty_args n_eq_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
- , Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg
- = Just (val_args !! index)
+ , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
+ , let val_args = drop n_eq_args con_args
+ = Just (val_args !! val_index)
| otherwise
= Nothing
\end{code}
-- Type variable case
go (arg:args) stricts us
- | isTyVar arg
+ | isTyCoVar arg
= let (binds, args') = go args stricts us
in (binds, arg:args')
-> 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 (`tcEqPred` pred) theta
+ -- See the DFun Superclass Invariant in TcInstDcls
\end{code}
another gun with which to shoot yourself in the foot.
\begin{code}
-mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
-mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
-
-unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-lazyIdName, errorName, recSelErrorName, runtimeErrorName :: Name
-irrefutPatErrorName, recConErrorName, patErrorName :: Name
-nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+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
-
-errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
-recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
-irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
-recConErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID
-patErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError") patErrorIdKey pAT_ERROR_ID
-noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
- noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
-nonExhaustiveGuardsErrorName
- = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError")
- nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
\end{code}
\begin{code}
`setSpecInfo` mkSpecInfo [seq_cast_rule]
- ty = mkForAllTys [alphaTyVar,openBetaTyVar]
- (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
- [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
- rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
+ ty = mkForAllTys [alphaTyVar,argBetaTyVar]
+ (mkFunTy alphaTy (mkFunTy argBetaTy argBetaTy))
+ [x,y] = mkTemplateLocals [alphaTy, argBetaTy]
+ rhs = mkLams [alphaTyVar,argBetaTyVar,x,y] (Case (Var x) x argBetaTy [(DEFAULT, [], Var y)])
-- See Note [Built-in RULES for seq]
seq_cast_rule = BuiltinRule { ru_name = fsLit "seq of cast"
Note [seqId magic]
~~~~~~~~~~~~~~~~~~
-'GHC.Prim.seq' is special in several ways.
+'GHC.Prim.seq' is special in several ways.
a) Its second arg can have an unboxed type
x `seq` (v +# w)
d) There is some special rule handing: Note [User-defined RULES for seq]
+e) See Note [Typing rule for seq] in TcExpr.
+
Note [User-defined RULES for seq]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Roman found situations where he had
\end{code}
-%************************************************************************
-%* *
-\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
-%* *
-%************************************************************************
-
-GHC randomly injects these into the code.
-
-@patError@ is just a version of @error@ for pattern-matching
-failures. It knows various ``codes'' which expand to longer
-strings---this saves space!
-
-@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
-well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absentErr@ (rather than a totally random
-crash).
-
-@parError@ is a special version of @error@ which the compiler does
-not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
-templates, but we don't ever expect to generate code for it.
-
-\begin{code}
-mkRuntimeErrorApp
- :: Id -- Should be of type (forall a. Addr# -> a)
- -- where Addr# points to a UTF8 encoded string
- -> Type -- The type to instantiate 'a'
- -> String -- The string to print
- -> CoreExpr
-
-mkRuntimeErrorApp err_id res_ty err_msg
- = mkApps (Var err_id) [Type res_ty, err_string]
- where
- err_string = Lit (mkMachString err_msg)
-
-mkImpossibleExpr :: Type -> CoreExpr
-mkImpossibleExpr res_ty
- = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
-
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
-pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
-rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
-rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
-iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
-rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
-pAT_ERROR_ID = mkRuntimeErrorId patErrorName
-nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-
--- The runtime error Ids take a UTF8-encoded string as argument
-
-mkRuntimeErrorId :: Name -> Id
-mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
-
-runtimeErrorTy :: Type
-runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
-\end{code}
-
-\begin{code}
-eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id errorName errorTy
-
-errorTy :: Type
-errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
- -- Notice the openAlphaTyVar. It says that "error" can be applied
- -- to unboxed as well as boxed types. This is OK because it never
- -- returns, so the return type is irrelevant.
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Utilities}
-%* *
-%************************************************************************
-
\begin{code}
pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId name ty info
-- random calls to GHCbase.unpackPS__. If GHCbase is the module
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
-
-pc_bottoming_Id :: Name -> Type -> Id
--- Function of arity 1, which diverges after being given one argument
-pc_bottoming_Id name ty
- = pcMiscPrelId name ty bottoming_info
- where
- bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
- `setArityInfo` 1
- -- Make arity and strictness agree
-
- -- Do *not* mark them as NoCafRefs, because they can indeed have
- -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
- -- which has some CAFs
- -- In due course we may arrange that these error-y things are
- -- regarded by the GC as permanently live, in which case we
- -- can give them NoCaf info. As it is, any function that calls
- -- any pc_bottoming_Id will itself have CafRefs, which bloats
- -- SRTs.
-
- strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
- -- These "bottom" out, no matter what their arguments
\end{code}
-