X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FMkId.lhs;h=1da519af6f517115fdaafd0d1ecb8cd33d2abe75;hb=ff2df1d2f393e85ed32bbe43b3d719dd3b6f7572;hp=60e0c8da070aedce39077b26468a60dfc3a1f6b9;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 60e0c8d..1da519a 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, @@ -37,8 +37,8 @@ module MkId ( import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) -import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, betaTyVar, betaTy, - intPrimTy, realWorldStatePrimTy, addrPrimTy +import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, + realWorldStatePrimTy, addrPrimTy ) import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) @@ -58,24 +58,23 @@ import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar, Var ) import VarSet ( isEmptyVarSet ) import Name ( mkFCallName, Name ) -import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName ) +import PrimOp ( PrimOp, 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, hasCafIdInfo, - setUnfoldingInfo, +import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCafInfo, - setAllStrictnessInfo, + setAllStrictnessInfo, vanillaIdInfo, GlobalIdDetails(..), CafInfo(..) ) import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), @@ -138,7 +137,6 @@ ghcPrimIds realWorldPrimId, unsafeCoerceId, nullAddrId, - getTagId, seqId ] \end{code} @@ -150,18 +148,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 @@ -238,18 +236,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) @@ -265,35 +285,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 @@ -302,9 +302,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) @@ -386,12 +383,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 @@ -488,10 +485,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 } @@ -504,7 +501,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 @@ -589,12 +586,25 @@ 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. \begin{code} mkDictSelId :: Name -> Class -> Id mkDictSelId name clas - = mkGlobalId (RecordSelId field_lbl) name sel_ty info + = mkGlobalId (ClassOpId clas) name sel_ty info where sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) -- We can't just say (exprType rhs), because that would give a type @@ -740,17 +750,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) @@ -834,10 +845,10 @@ seqId 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 @@ -857,24 +868,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 getTagName 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@). @@ -976,7 +969,7 @@ pcMiscPrelId name ty info pc_bottoming_Id name ty = pcMiscPrelId name ty bottoming_info where - bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig + bottoming_info = vanillaIdInfo `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