X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=8485e1867f93e4ad3b5d499df8c337d180cb0122;hb=663b391470a783e8f23414c07c18a020850d2fb8;hp=6f664da7a0584538629b00df7d70bc7dc5704219;hpb=70918cf4a4d61d4752b18f29ce14c7d7f1fbce01;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 6f664da..8485e18 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -21,6 +21,7 @@ module MkId ( mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, + wrapFamInstBody, unwrapFamInstScrut, mkUnpackCase, mkProductBox, -- And some particular Ids; see below for why they are wired in @@ -43,6 +44,7 @@ import TysPrim import TysWiredIn import PrelRules import Type +import TypeRep import TcGadt import Coercion import TcType @@ -58,7 +60,7 @@ import PrimOp import ForeignCall import DataCon import Id -import Var ( Var, TyVar) +import Var ( Var, TyVar, mkCoVar) import IdInfo import NewDemand import DmdAnal @@ -72,7 +74,7 @@ import Outputable import FastString import ListSetOps import Module -\end{code} +\end{code} %************************************************************************ %* * @@ -181,10 +183,12 @@ tyConFamilyCoercion_maybe and has kind The wrapper and worker of MapPair get the types + -- Wrapper $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $WMapPair a b v = $wMapPair a b v `cast` sym (Co123Map a b v) + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) - $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v This coercion is conditionally applied by wrapFamInstBody. @@ -197,17 +201,18 @@ Hence Now we want + -- Wrapper $WT1 :: forall b. b -> T [Maybe b] - $WT1 a b v = $wT1 b (Maybe b) (Maybe b) + $WT1 b v = T1 (Maybe b) b (Maybe b) v `cast` sym (Co7T (Maybe b)) - $wT1 :: forall b c. (b ~ Maybe c) => b -> :R7T c + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c \begin{code} mkDataConIds :: Name -> Name -> DataCon -> DataConIds mkDataConIds wrap_name wkr_name data_con | isNewTyCon tycon -- Newtype, only has a worker - , not (isFamInstTyCon tycon) -- unless it's a family instancex = DCIds Nothing nt_work_id | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper @@ -219,20 +224,8 @@ mkDataConIds wrap_name wkr_name data_con = DCIds Nothing wrk_id where (univ_tvs, ex_tvs, eq_spec, - theta, orig_arg_tys, res_ty) = dataConFullSig data_con - res_ty_args = tyConAppArgs res_ty - tycon = dataConTyCon data_con - - ----------- Wrapper -------------- - -- We used to include the stupid theta in the wrapper's args - -- but now we don't. Instead the type checker just injects these - -- extra constraints where necessary. - wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs - dict_tys = mkPredTys theta - wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ - mkFunTys orig_arg_tys $ res_ty - -- NB: watch out here if you allow user-written equality - -- constraints in data constructor signatures + eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con + tycon = dataConTyCon data_con -- The representation TyCon (not family) ----------- Worker (algebraic data types only) -------------- -- The *worker* for the data constructor is the function that @@ -278,8 +271,11 @@ mkDataConIds wrap_name wkr_name data_con nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setUnfoldingInfo` newtype_unf - newtype_unf = ASSERT( isVanillaDataCon data_con && - isSingleton orig_arg_tys ) + newtype_unf = -- The assertion below is no longer correct: + -- there may be a dict theta rather than a singleton orig_arg_ty + -- ASSERT( isVanillaDataCon data_con && + -- isSingleton orig_arg_tys ) + -- -- No existentials on a newtype, but it can have a context -- e.g. newtype Eq a => T a = MkT (...) mkCompulsoryUnfolding $ @@ -287,15 +283,32 @@ mkDataConIds wrap_name wkr_name data_con wrapNewTypeBody tycon res_ty_args (Var id_arg1) - id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) + id_arg1 = mkTemplateLocal 1 + (if null orig_arg_tys + then ASSERT(not (null $ dataConDictTheta data_con)) mkPredTy $ head (dataConDictTheta data_con) + else head orig_arg_tys + ) + + ----------- Wrapper -------------- + -- We used to include the stupid theta in the wrapper's args + -- but now we don't. Instead the type checker just injects these + -- 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 ----------- Wrappers for algebraic data types -------------- alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` alg_arity + `setArityInfo` wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setUnfoldingInfo` alg_unf + `setUnfoldingInfo` wrap_unf `setAllStrictnessInfo` Just wrap_sig all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con @@ -312,8 +325,9 @@ 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 - alg_unf = mkTopUnfolding $ Note InlineMe $ + wrap_unf = mkTopUnfolding $ Note InlineMe $ mkLams wrap_tvs $ + mkLams eq_args $ mkLams dict_args $ mkLams id_args $ foldr mk_case con_app (zip (dict_args ++ id_args) all_strict_marks) @@ -323,11 +337,18 @@ mkDataConIds wrap_name wkr_name data_con Var wrk_id `mkTyApps` res_ty_args `mkVarApps` ex_tvs `mkTyApps` map snd eq_spec -- Equality evidence + `mkVarApps` eq_args `mkVarApps` reverse rep_ids (dict_args,i2) = mkLocals 1 dict_tys (id_args,i3) = mkLocals i2 orig_arg_tys - alg_arity = i3-1 + 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) mk_case :: (Id, StrictnessMark) -- Arg, strictness @@ -474,7 +495,8 @@ mkRecordSelId tycon field_label | otherwise = sel_id where is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set) - sel_id_details = RecordSelId tycon field_label is_naughty + sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty } + -- For a data type family, the tycon is the *instance* TyCon -- Escapist case here for naughty constructors -- We give it no IdInfo, and a type of forall a.a (never looked at) @@ -487,8 +509,10 @@ mkRecordSelId tycon field_label data_cons_w_field = filter has_field data_cons -- Can't be empty! has_field con = field_label `elem` dataConFieldLabels con - con1 = head data_cons_w_field - (univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1 + con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field + (univ_tvs, _, eq_spec, _, _, _, data_ty) = dataConFullSig con1 + -- For a data type family, the data_ty (and hence selector_ty) mentions + -- only the family TyCon, not the instance TyCon data_tv_set = tyVarsOfType data_ty data_tvs = varSetElems data_tv_set field_ty = dataConFieldType con1 field_label @@ -785,7 +809,7 @@ mkDictSelId name clas -- C a -> C a -- for a single-op class (after all, the selector is the identity) -- But it's type must expose the representation of the dictionary - -- to gat (say) C a -> (a -> a) + -- to get (say) C a -> (a -> a) info = noCafIdInfo `setArityInfo` 1 @@ -807,16 +831,24 @@ mkDictSelId name clas tycon = classTyCon clas [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con - arg_tys = ASSERT( isVanillaDataCon data_con ) dataConRepArgTys data_con + arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con + eq_theta = dataConEqTheta data_con the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name - pred = mkClassPred clas (mkTyVarTys tyvars) - (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys) + 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) - rhs = mkLams tyvars (Lam dict_id rhs_body) + rhs = mkLams tyvars (Lam dict_id rhs_body) rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, arg_ids, Var the_arg_id)] + [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] \end{code} @@ -1127,7 +1159,7 @@ seqId -- not from GHC.Base.hi. This is important, because the strictness -- analyser will spot it as strict! -- --- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapper pass +-- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapperpass -- (see WorkWrap.wwExpr) -- We could use inline phases to do this, but that would be vulnerable to changes in -- phase numbering....we must inline precisely after strictness analysis.