X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=67cf5e4a6ca18a3df566c04d426a58549842625b;hp=54bbae9ea47d9a34c1bdadbaf5c71ac48ec66d7e;hb=cdce647711c0f46f5799b24de087622cb77e647f;hpb=d76c18e05f6366c23144624b696a02fbaa6d26e8 diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 54bbae9..67cf5e4 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1,7 +1,7 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1998 % -\section[StdIdInfo]{Standard unfoldings} This module contains definitions for the IdInfo for things that have a standard form, namely: @@ -18,7 +18,7 @@ module MkId ( mkDataConIds, mkRecordSelId, - mkPrimOpId, mkFCallId, + mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, mkUnpackCase, mkProductBox, @@ -38,70 +38,41 @@ module MkId ( #include "HsVersions.h" - -import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) -import Rules ( mkSpecInfo ) -import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, - realWorldStatePrimTy, addrPrimTy - ) -import TysWiredIn ( charTy, mkListTy ) -import PrelRules ( primOpRules ) -import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, - newTyConInstRhs, mkTopTvSubst, substTyVar, substTy ) -import TcGadt ( gadtRefine, refineType, emptyRefinement ) -import HsBinds ( ExprCoFn(..), isIdCoercion ) -import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred ) -import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, - mkTyConApp, mkTyVarTys, mkClassPred, isPredTy, - mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType, - isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, - tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta - ) -import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce ) -import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) -import Literal ( nullAddrLit, mkStringLit ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, - tyConStupidTheta, isProductTyCon, isDataTyCon, - isRecursiveTyCon, isFamInstTyCon, - tyConFamInst_maybe, tyConFamilyCoercion_maybe, - newTyConCo_maybe ) -import Class ( Class, classTyCon, classSelIds ) -import Var ( Id, TyVar, Var, setIdType ) -import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) -import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..)) -import OccName ( mkOccNameFS, varName ) -import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) -import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, DataConIds(..), dataConTyCon, - dataConUnivTyVars, - dataConFieldLabels, dataConRepArity, dataConResTys, - dataConRepArgTys, dataConRepType, dataConFullSig, - dataConStrictMarks, dataConExStricts, - splitProductType, isVanillaDataCon, dataConFieldType, - deepSplitProductType, - ) -import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, - mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, - mkTemplateLocal, idName - ) -import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, - setArityInfo, setSpecInfo, setCafInfo, - setAllStrictnessInfo, vanillaIdInfo, - GlobalIdDetails(..), CafInfo(..) - ) -import NewDemand ( mkStrictSig, DmdResult(..), - mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR, - Demand(..), Demands(..) ) -import DmdAnal ( dmdAnalTopRhs ) +import Rules +import TysPrim +import TysWiredIn +import PrelRules +import Type +import TcGadt +import HsBinds +import Coercion +import TcType +import CoreUtils +import CoreUnfold +import Literal +import TyCon +import Class +import VarSet +import Name +import OccName +import PrimOp +import ForeignCall +import DataCon +import Id +import Var ( Var, TyVar) +import IdInfo +import NewDemand +import DmdAnal import CoreSyn -import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) -import Maybe ( fromJust ) +import Unique import Maybes import PrelNames -import Util ( dropList, isSingleton ) +import BasicTypes hiding ( SuccessFlag(..) ) +import Util import Outputable import FastString -import ListSetOps ( assoc, minusList ) +import ListSetOps +import Module \end{code} %************************************************************************ @@ -240,15 +211,23 @@ mkDataConIds wrap_name wkr_name data_con -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs subst = mkTopTvSubst eq_spec + famSubst = ASSERT( length (tyConTyVars tycon ) == + length (mkTyVarTys univ_tvs) ) + zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) + -- substitution mapping the type constructor's type + -- arguments to the universals of the data constructor + -- (crucial when type checking interfaces) dict_tys = mkPredTys theta - result_ty_args = map (substTyVar subst) univ_tvs + result_ty_args = substTyVars subst univ_tvs result_ty = case tyConFamInst_maybe tycon of -- ordinary constructor Nothing -> mkTyConApp tycon result_ty_args -- family instance constructor Just (familyTyCon, instTys) -> - mkTyConApp familyTyCon (map (substTy subst) instTys) + mkTyConApp familyTyCon ( substTys subst + . substTys famSubst + $ instTys) wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ mkFunTys orig_arg_tys $ result_ty -- NB: watch out here if you allow user-written equality @@ -268,6 +247,7 @@ mkDataConIds wrap_name wkr_name data_con -- even if arity = 0 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) + -- Note [Data-con worker strictness] -- Notice that we do *not* say the worker is strict -- even if the data constructor is declared strict -- e.g. data T = MkT !(Int,Int) @@ -393,16 +373,6 @@ wrapFamInstBody tycon args result_expr = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr | otherwise = result_expr - --- Apply the coercion in the opposite direction. --- -unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapFamInstBody tycon args result_expr - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkTyConApp co_con args) result_expr - | otherwise - = result_expr - \end{code} @@ -624,14 +594,14 @@ mkRecordSelId tycon field_label -- T1 b' (c : [b]=[b']) (x:Maybe b') -- -> x `cast` Maybe (sym (right c)) - Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs - (co_fn, res_ty) = refineType refinement (idType the_arg_id) + -- Generate the refinement for b'=b, -- and apply to (Maybe b'), to get (Maybe b) - - rhs = case co_fn of - ExprCoFn co -> Cast (Var the_arg_id) co - id_co -> ASSERT(isIdCoercion id_co) Var the_arg_id + Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs + the_arg_id_ty = idType the_arg_id + (rhs, res_ty) = case refineType refinement the_arg_id_ty of + Just (co, res_ty) -> (Cast (Var the_arg_id) co, res_ty) + Nothing -> (Var the_arg_id, the_arg_id_ty) field_vs = filter (not . isPredTy . idType) arg_vs the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label @@ -896,7 +866,7 @@ mkPrimOpId prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) - Nothing (AnId id) UserSyntax + (AnId id) UserSyntax id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo @@ -934,6 +904,29 @@ mkFCallId uniq fcall ty (arg_tys, _) = tcSplitFunTys tau arity = length arg_tys strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes) + +-- Tick boxes and breakpoints are both represented as TickBoxOpIds, +-- except for the type: +-- +-- a plain HPC tick box has type (State# RealWorld) +-- a breakpoint Id has type forall a.a +-- +-- The breakpoint Id will be applied to a list of arbitrary free variables, +-- which is why it needs a polymorphic type. + +mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id +mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy + +mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id +mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty + where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy + +mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info + where + tickbox = TickBox mod ix + occ_str = showSDoc (braces (ppr tickbox)) + name = mkTickBoxOpName uniq occ_str + info = noCafIdInfo \end{code} @@ -1035,7 +1028,7 @@ another gun with which to shoot yourself in the foot. \begin{code} mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax + = 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 @@ -1068,8 +1061,7 @@ unsafeCoerceId (mkFunTy openAlphaTy openBetaTy) [x] = mkTemplateLocals [openAlphaTy] rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ --- Note (Coerce openBetaTy openAlphaTy) (Var x) - Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) + Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) -- nullAddr# :: Addr# -- The reason is is here is because we don't provide @@ -1227,9 +1219,5 @@ pc_bottoming_Id name ty strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes) -- These "bottom" out, no matter what their arguments - -(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars -openAlphaTy = mkTyVarTy openAlphaTyVar -openBetaTy = mkTyVarTy openBetaTyVar \end{code}