X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=c691f62676f45216a3c563d4a102a610dec196a6;hp=6d8df877a9ee8203e42beb14b1c1a1b3539b50ec;hb=1b381af863d64aaa0a4dd9c816170c58e6131a9e;hpb=3bc73cd67e6cfacd2fc823019f1b6012cdf1ccb4 diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 6d8df87..c691f62 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -12,16 +12,8 @@ have a standard form, namely: - primitive operations \begin{code} -{-# OPTIONS -fno-warn-missing-signatures #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- --- for details - module MkId ( - mkDictFunId, mkDefaultMethodId, - mkDictSelId, + mkDictFunId, mkDictFunTy, mkDictSelId, mkDataConIds, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, @@ -32,26 +24,24 @@ module MkId ( -- 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, unsafeCoerceId, realWorldPrimId, + voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, - unsafeCoerceName + -- Re-export error Ids + module PrelRules ) where #include "HsVersions.h" import Rules import TysPrim -import TysWiredIn +import TysWiredIn ( unitTy ) import PrelRules import Type import Coercion import TcType +import MkCore import CoreUtils ( exprType, mkCoerce ) import CoreUnfold import Literal @@ -63,14 +53,15 @@ import PrimOp import ForeignCall import DataCon import Id -import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar ) +import Var ( mkExportedLocalVar ) import IdInfo -import NewDemand +import Demand import CoreSyn import Unique import PrelNames import BasicTypes hiding ( SuccessFlag(..) ) import Util +import Pair import Outputable import FastString import ListSetOps @@ -118,24 +109,9 @@ is right here. \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] @@ -225,10 +201,8 @@ It's a bit more complicated if the data instance is a GADT as well! data instance T [a] where T1 :: forall b. b -> T [Maybe b] -Hence - Co7T a :: T [a] ~ :R7T a -Now we want +Hence we translate to -- Wrapper $WT1 :: forall b. b -> T [Maybe b] @@ -238,22 +212,25 @@ Now we want -- Worker T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + \begin{code} mkDataConIds :: Name -> Name -> DataCon -> DataConIds mkDataConIds wrap_name wkr_name data_con | isNewTyCon tycon -- Newtype, only has a worker = DCIds Nothing nt_work_id - | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper - || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs - || isFamInstTyCon tycon -- depends on this test + | any isBanged all_strict_marks -- Algebraic, needs wrapper + || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs + || isFamInstTyCon tycon -- depends on this test = DCIds (Just alg_wrap_id) wrk_id | otherwise -- Algebraic, no wrapper = 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) -------------- @@ -264,9 +241,9 @@ mkDataConIds wrap_name wkr_name data_con wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setAllStrictnessInfo` Just wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + `setArityInfo` wkr_arity + `setStrictnessInfo` Just wkr_sig + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) @@ -299,6 +276,7 @@ mkDataConIds wrap_name wkr_name data_con 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 && @@ -315,12 +293,10 @@ mkDataConIds wrap_name wkr_name data_con -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs - eq_tys = mkPredTys eq_theta - dict_tys = mkPredTys dict_theta - wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $ - mkFunTys orig_arg_tys $ res_ty - -- NB: watch out here if you allow user-written equality - -- constraints in data constructor signatures + ev_tys = mkPredTys other_theta + wrap_ty = mkForAllTys wrap_tvs $ + mkFunTys ev_tys $ + mkFunTys orig_arg_tys $ res_ty ----------- Wrappers for algebraic data types -------------- alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info @@ -328,14 +304,16 @@ mkDataConIds wrap_name wkr_name data_con `setArityInfo` wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values + `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` wrap_unf - `setAllStrictnessInfo` Just wrap_sig + `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 - mk_dmd str | isMarkedStrict str = evalDmd - | otherwise = lazyDmd + 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 -- wrapper constructor isn't inlined. -- And the argument strictness can be important too; we @@ -345,50 +323,43 @@ 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 = mkInlineRule InlSat wrap_rhs (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, StrictnessMark) -- Arg, strictness + :: (Id, HsBang) -- Arg, strictness -> (Int -> [Id] -> CoreExpr) -- Body -> Int -- Next rep arg id -> [Id] -- Rep args so far, reversed -> CoreExpr mk_case (arg,strict) body i rep_args = case strict of - NotMarkedStrict -> body i (arg:rep_args) - MarkedStrict - | isUnLiftedType (idType arg) -> body i (arg:rep_args) - | otherwise -> - Case (Var arg) arg res_ty [(DEFAULT,[], body i (arg:rep_args))] - - MarkedUnboxed - -> unboxProduct i (Var arg) (idType arg) the_body + HsNoBang -> body i (arg:rep_args) + HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body where the_body i con_args = body i (reverse con_args ++ rep_args) + _other -- HsUnpackFailed and HsStrict + | isUnLiftedType (idType arg) -> body i (arg:rep_args) + | otherwise -> Case (Var arg) arg res_ty + [(DEFAULT,[], body i (arg:rep_args))] mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 @@ -401,6 +372,7 @@ mAX_CPR_SIZE = 10 -- by the caller. So doing CPR for them may in fact make -- things worse. +mkLocals :: Int -> [Type] -> ([Id], Int) mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) where n = length tys @@ -443,10 +415,12 @@ at the outside. When dealing with classes it's very convenient to 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 @@ -459,23 +433,21 @@ mkDictSelId no_unf name clas base_info = noCafIdInfo `setArityInfo` 1 - `setAllStrictnessInfo` 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 | new_tycon = base_info - -- For newtype dictionaries, just inline the class op - -- See Note [Single-method classes] in TcInstDcls - | otherwise = base_info - `setSpecInfo` mkSpecInfo [rule] - `setInlinePragInfo` neverInlinePragma - -- Otherwise 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 @@ -485,7 +457,7 @@ mkDictSelId no_unf name clas 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 } -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting @@ -496,41 +468,37 @@ mkDictSelId no_unf name clas | 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 - - 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 - - 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) + tycon = classTyCon clas + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + -- '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..] + + the_arg_id = arg_ids !! val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 $ mkPredTy pred + arg_ids = mkTemplateLocalsNum 2 arg_tys 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 -> [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 + [(DataAlt data_con, arg_ids, Var the_arg_id)] + +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 -- --- NB: the data constructor has the same number of type args as the class op - -dictSelRule index n_ty_args args +dictSelRule val_index n_ty_args id_unf args | (dict_arg : _) <- drop n_ty_args args - , Just (_, _, val_args) <- exprIsConApp_maybe dict_arg - = Just (val_args !! index) + , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (con_args !! val_index) | otherwise = Nothing \end{code} @@ -634,7 +602,7 @@ mkProductBox arg_ids ty mkReboxingAlt :: [Unique] -- Uniques for the new Ids -> DataCon - -> [Var] -- Source-level args, including existential dicts + -> [Var] -- Source-level args, *including* all evidence vars -> CoreExpr -- RHS -> CoreAlt @@ -662,8 +630,7 @@ mkReboxingAlt us con args rhs -- 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') @@ -701,13 +668,11 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- coercion constructor of the newtype or applied by itself). wrapNewTypeBody tycon args result_expr - = wrapFamInstBody tycon args inner + = ASSERT( isNewTyCon tycon ) + wrapFamInstBody tycon args $ + mkCoerce (mkSymCo co) result_expr where - inner - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr - | otherwise - = result_expr + co = mkAxInstCo (newTyConCo tycon) args -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as @@ -716,10 +681,8 @@ wrapNewTypeBody tycon args result_expr unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkTyConApp co_con args) result_expr - | otherwise - = result_expr + = ASSERT( isNewTyCon tycon ) + mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr -- If the type constructor is a representation type of a data instance, wrap -- the expression into a cast adjusting the expression type, which is an @@ -729,14 +692,14 @@ unwrapNewTypeBody tycon args result_expr wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body + = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body | otherwise = body unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkTyConApp co_con args) scrut + = mkCoerce (mkAxInstCo co_con args) scrut | otherwise = scrut \end{code} @@ -763,7 +726,7 @@ mkPrimOpId prim_op info = noCafIdInfo `setSpecInfo` mkSpecInfo (primOpRules prim_op name) `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig + `setStrictnessInfo` Just strict_sig -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, @@ -789,7 +752,7 @@ mkFCallId uniq fcall ty info = noCafIdInfo `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig + `setStrictnessInfo` Just strict_sig (_, tau) = tcSplitForAllTys ty (arg_tys, _) = tcSplitFunTys tau @@ -812,6 +775,7 @@ mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy +mkTickBox' :: Unique -> Module -> TickBoxId -> Type -> Id mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info where tickbox = TickBox mod ix @@ -852,20 +816,35 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty - 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} @@ -891,42 +870,31 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} -mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax - -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 +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} ------------------------------------------------ -- unsafeCoerce# :: forall a b. a -> b +unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] - (mkFunTy openAlphaTy openBetaTy) - [x] = mkTemplateLocals [openAlphaTy] - rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) + ty = mkForAllTys [argAlphaTyVar,openBetaTyVar] + (mkFunTy argAlphaTy openBetaTy) + [x] = mkTemplateLocals [argAlphaTy] + rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $ + Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -935,21 +903,22 @@ 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,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" @@ -958,12 +927,12 @@ seqId = pcMiscPrelId seqName ty info , ru_try = match_seq_of_cast } -match_seq_of_cast :: [CoreExpr] -> Maybe CoreExpr +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, +match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] + = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, scrut, expr]) -match_seq_of_cast _ = Nothing +match_seq_of_cast _ _ = Nothing ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] @@ -975,7 +944,7 @@ lazyId = pcMiscPrelId lazyIdName ty info 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) @@ -987,6 +956,8 @@ c) It has quite a bit of desugaring magic. 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 @@ -1057,6 +1028,7 @@ E.g. This comes up in strictness analysis \begin{code} +realWorldPrimId :: Id realWorldPrimId -- :: State# RealWorld = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) @@ -1068,81 +1040,15 @@ realWorldPrimId -- :: State# RealWorld voidArgId :: Id voidArgId -- :: State# RealWorld = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy -\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 = 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 = 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. +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- Used to replace Coercion terms when we go to STG + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPredPrimTyCon [unitTy, unitTy]) + noCafIdInfo \end{code} -%************************************************************************ -%* * -\subsection{Utilities} -%* * -%************************************************************************ - \begin{code} pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info @@ -1152,26 +1058,4 @@ 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 `setAllStrictnessInfo` 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} -