X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FMkId.lhs;h=8be584426d8eed3c43266794bbde3950732ab32f;hb=b749b2c7fd7fb9cdd464c213672ded760f498dc9;hp=d8fab3cb8573ac7a688e5caa0038598e6dac66e5;hpb=80e399639dc521561cc9fe33e6f24079c4eae609;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index d8fab3c..8be5844 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -16,7 +16,7 @@ module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, - mkDataConId, mkDataConWrapId, + mkDataConWorkId, mkDataConWrapId, mkRecordSelId, mkPrimOpId, mkFCallId, @@ -49,7 +49,6 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tcSplitFunTys, tcSplitForAllTys, mkPredTy ) -import Module ( Module ) import CoreUtils ( exprType ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) import Literal ( Literal(..), nullAddrLit ) @@ -58,23 +57,22 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar, Var ) import VarSet ( isEmptyVarSet ) -import Name ( mkWiredInName, mkFCallName, Name ) -import OccName ( mkVarOcc ) +import Name ( mkFCallName, Name ) import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConFieldLabels, dataConRepArity, dataConTyCon, dataConArgTys, dataConRepType, dataConOrigArgTys, - dataConName, dataConTheta, + dataConTheta, dataConSig, dataConStrictMarks, dataConWorkId, splitProductType ) -import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, - mkTemplateLocals, mkTemplateLocalsNum, +import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId, + mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported, mkTemplateLocal, idNewStrictness, idName ) -import IdInfo ( IdInfo, noCafIdInfo, +import IdInfo ( IdInfo, noCafIdInfo, hasCafIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCafInfo, setAllStrictnessInfo, @@ -98,7 +96,6 @@ import FastString import ListSetOps ( assoc, assocMaybe ) import UnicodeUtil ( stringToUtf8 ) import List ( nubBy ) -import Char ( ord ) \end{code} %************************************************************************ @@ -141,7 +138,6 @@ ghcPrimIds realWorldPrimId, unsafeCoerceId, nullAddrId, - getTagId, seqId ] \end{code} @@ -153,18 +149,18 @@ ghcPrimIds %************************************************************************ \begin{code} -mkDataConId :: Name -> DataCon -> Id +mkDataConWorkId :: Name -> DataCon -> Id -- Makes the *worker* for the data constructor; that is, the function -- that takes the reprsentation arguments and builds the constructor. -mkDataConId work_name data_con - = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info +mkDataConWorkId wkr_name data_con + = mkGlobalId (DataConWorkId data_con) wkr_name + (dataConRepType data_con) info where info = noCafIdInfo `setArityInfo` arity `setAllStrictnessInfo` Just strict_sig arity = dataConRepArity data_con - strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info) -- Notice that we do *not* say the worker is strict -- even if the data constructor is declared strict @@ -241,18 +237,40 @@ Notice that it in the (common) case where the constructor arg is already evaluated. \begin{code} -mkDataConWrapId data_con - = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info +mkDataConWrapId :: Name -> DataCon -> Maybe Id +-- Only make a wrapper Id if necessary + +mkDataConWrapId wrap_name data_con + | is_newtype || any isMarkedStrict strict_marks + = -- We need a wrapper function + Just (mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty info) + + | otherwise + = Nothing -- The common case, where there is no point in + -- having a wrapper function. Not only is this efficient, + -- but it also ensures that the wrapper is replaced + -- by the worker (becuase it *is* the wroker) + -- even when there are no args. E.g. in + -- f (:) x + -- the (:) *is* the worker. + -- This is really important in rule matching, + -- (We could match on the wrappers, + -- but that makes it less likely that rules will match + -- when we bring bits of unfoldings together.) where - work_id = dataConWorkId data_con + (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con + is_newtype = isNewTyCon tycon + all_tyvars = tyvars ++ ex_tyvars + work_id = dataConWorkId data_con - info = noCafIdInfo - `setUnfoldingInfo` wrap_unf - -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` arity + common_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setAllStrictnessInfo` Just wrap_sig + + info | is_newtype = common_info `setUnfoldingInfo` newtype_unf + | otherwise = common_info `setUnfoldingInfo` data_unf + `setAllStrictnessInfo` Just wrap_sig wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info) res_info = strictSigResInfo (idNewStrictness work_id) @@ -268,35 +286,15 @@ mkDataConWrapId data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf | isNewTyCon tycon - = ASSERT( null ex_tyvars && null ex_dict_args && isSingleton orig_arg_tys ) - -- No existentials on a newtype, but it can have a context - -- e.g. newtype Eq a => T a = MkT (...) - mkTopUnfolding $ Note InlineMe $ - mkLams tyvars $ Lam id_arg1 $ - mkNewTypeBody tycon result_ty (Var id_arg1) - - | not (any isMarkedStrict strict_marks) - = mkCompulsoryUnfolding (Var work_id) - -- The common case. Not only is this efficient, - -- but it also ensures that the wrapper is replaced - -- by the worker even when there are no args. - -- f (:) x - -- becomes - -- f $w: x - -- This is really important in rule matching, - -- (We could match on the wrappers, - -- but that makes it less likely that rules will match - -- when we bring bits of unfoldings together.) - -- - -- NB: because of this special case, (map (:) ys) turns into - -- (map $w: ys). The top-level defn for (:) is never used. - -- This is somewhat of a bore, but I'm currently leaving it - -- as is, so that there still is a top level curried (:) for - -- the interpreter to call. - - | otherwise - = mkTopUnfolding $ Note InlineMe $ + newtype_unf = ASSERT( null ex_tyvars && null ex_dict_args && + isSingleton orig_arg_tys ) + -- No existentials on a newtype, but it can have a context + -- e.g. newtype Eq a => T a = MkT (...) + mkTopUnfolding $ Note InlineMe $ + mkLams tyvars $ Lam id_arg1 $ + mkNewTypeBody tycon result_ty (Var id_arg1) + + data_unf = mkTopUnfolding $ Note InlineMe $ mkLams all_tyvars $ mkLams ex_dict_args $ mkLams id_args $ foldr mk_case con_app @@ -305,9 +303,6 @@ mkDataConWrapId data_con con_app i rep_ids = mkApps (Var work_id) (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) - (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con - all_tyvars = tyvars ++ ex_tyvars - ex_dict_tys = mkPredTys ex_theta all_arg_tys = ex_dict_tys ++ orig_arg_tys result_ty = mkTyConApp tycon (mkTyVarTys tyvars) @@ -389,12 +384,12 @@ Then we want (not f :: R -> forall a. a->a, which gives the type inference mechanism problems at call sites) -Similarly for newtypes +Similarly for (recursive) newtypes newtype N = MkN { unN :: forall a. a->a } - unN :: forall a. N -> a -> a - unN = /\a -> \n:N -> coerce (a->a) n + unN :: forall b. N -> b -> b + unN = /\b -> \n:N -> (coerce (forall a. a->a) n) \begin{code} mkRecordSelId tycon field_label @@ -483,7 +478,7 @@ mkRecordSelId tycon field_label default_alt | no_default = [] | otherwise = [(DEFAULT, [], error_expr)] - -- the default branch may have CAF refs, because it calls recSelError etc. + -- The default branch may have CAF refs, because it calls recSelError etc. caf_info | no_default = NoCafRefs | otherwise = MayHaveCafRefs @@ -491,10 +486,10 @@ mkRecordSelId tycon field_label mkLams dict_ids $ mkLams field_dict_ids $ Lam data_id $ sel_body - sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau (mk_result data_id) + sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id)) | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts) - mk_result result_id = mkVarApps (mkVarApps (Var result_id) field_tyvars) field_dict_ids + mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids -- We pull the field lambdas to the top, so we need to -- apply them in the body. For example: -- data T = MkT { foo :: forall a. a->a } @@ -507,7 +502,7 @@ mkRecordSelId tycon field_label Nothing -> Nothing Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids body) where - body = mk_result the_arg_id + body = mk_result (Var the_arg_id) where arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con) -- No need to instantiate; same tyvars in datacon as tycon @@ -592,7 +587,22 @@ mkReboxingAlt us con args rhs Selecting a field for a dictionary. If there is just one field, then there's nothing to do. -ToDo: unify with mkRecordSelId. +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +This is unlike ordinary record selectors, which have all the for-alls +at the outside. When dealing with classes it's very convenient to +recover the original type signature from the class op selector. + +ToDo: unify with mkRecordSelId? \begin{code} mkDictSelId :: Name -> Class -> Id @@ -743,17 +753,18 @@ BUT make sure they are *exported* LocalIds (setIdLocalExported) so that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId dm_name ty = mkVanillaGlobal dm_name ty noCafIdInfo +mkDefaultMethodId dm_name ty + = setIdLocalExported (mkLocalId dm_name ty) mkDictFunId :: Name -- Name to use for the dict fun; - -> Class -> [TyVar] - -> [Type] -> ThetaType + -> Class + -> [Type] -> Id -mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta - = mkVanillaGlobal dfun_name dfun_ty noCafIdInfo +mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys + = setIdLocalExported (mkLocalId dfun_name dfun_ty) where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) @@ -811,7 +822,7 @@ another gun with which to shoot yourself in the foot. \begin{code} -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId - = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info + = pcMiscPrelId unsafeCoerceName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -826,21 +837,21 @@ unsafeCoerceId -- The reason is is here is because we don't provide -- a way to write this literal in Haskell. nullAddrId - = pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info + = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) seqId - = pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info + = pcMiscPrelId seqName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkForAllTys [alphaTyVar,betaTyVar] - (mkFunTy alphaTy (mkFunTy betaTy betaTy)) - [x,y] = mkTemplateLocals [alphaTy, betaTy] - rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)]) + ty = mkForAllTys [alphaTyVar,openBetaTyVar] + (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy)) + [x,y] = mkTemplateLocals [alphaTy, openBetaTy] + rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)]) -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) -- Used to lazify pseq: pseq a b = a `seq` lazy b @@ -849,7 +860,7 @@ seqId -- the info in PrelBase.hi. This is important, because the strictness -- analyser will spot it as strict! lazyId - = pcMiscPrelId lazyIdKey pREL_BASE FSLIT("lazy") ty info + = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) @@ -860,24 +871,6 @@ lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x) [x] = mkTemplateLocals [openAlphaTy] \end{code} -@getTag#@ is another function which can't be defined in Haskell. It needs to -evaluate its argument and call the dataToTag# primitive. - -\begin{code} -getTagId - = pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info - where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - -- We don't provide a defn for this; you must inline it - - ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy) - [x,y] = mkTemplateLocals [alphaTy,alphaTy] - rhs = mkLams [alphaTyVar,x] $ - Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ] - -dataToTagId = mkPrimOpId DataToTagOp -\end{code} - @realWorld#@ used to be a magic literal, \tr{void#}. If things get nasty as-is, change it back to a literal (@Literal@). @@ -890,8 +883,7 @@ This comes up in strictness analysis \begin{code} realWorldPrimId -- :: State# RealWorld - = pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#") - realWorldStatePrimTy + = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` mkOtherCon []) -- The mkOtherCon makes it look that realWorld# is evaluated -- which in turn makes Simplify.interestingArg return True, @@ -937,22 +929,21 @@ mkRuntimeErrorApp err_id res_ty err_msg where err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg))) -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError") -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError") - -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError") -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError") -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError") -pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError") -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError") +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -- The runtime error Ids take a UTF8-encoded string as argument -mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) +mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy +runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) \end{code} \begin{code} -eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy +eRROR_ID = pc_bottoming_Id errorName errorTy errorTy :: Type errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) @@ -969,25 +960,30 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy %************************************************************************ \begin{code} -pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id -pcMiscPrelId key mod str ty info - = let - name = mkWiredInName mod (mkVarOcc str) key - imp = mkVanillaGlobal name ty info -- the usual case... - in - imp +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobal name ty info -- We lie and say the thing is imported; otherwise, we get into -- a mess with dependency analysis; e.g., core2stg may heave in -- 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 key mod name ty - = pcMiscPrelId key mod name ty bottoming_info +pc_bottoming_Id name ty + = pcMiscPrelId name ty bottoming_info where + bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig + -- 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) - bottoming_info = noCafIdInfo `setAllStrictnessInfo` Just strict_sig - -- these "bottom" out, no matter what their arguments + -- These "bottom" out, no matter what their arguments (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars openAlphaTy = mkTyVarTy openAlphaTyVar