X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=32b4ecfed06cdbbcf1c375d910ece5edb53d2815;hp=f72afb92640075188a20a8ed4860705ac0163f58;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=68f606a04198beb15b577ebc951d34a313710cdc diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index f72afb9..32b4ecf 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1,4 +1,4 @@ -% +\% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1998 % @@ -12,6 +12,13 @@ have a standard form, namely: * primitive operations \begin{code} +{-# OPTIONS -w #-} +-- 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 +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, @@ -21,6 +28,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 +51,7 @@ import TysPrim import TysWiredIn import PrelRules import Type +import TypeRep import TcGadt import Coercion import TcType @@ -58,7 +67,7 @@ import PrimOp import ForeignCall import DataCon import Id -import Var ( Var, TyVar) +import Var ( Var, TyVar, mkCoVar) import IdInfo import NewDemand import DmdAnal @@ -222,7 +231,7 @@ 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 + 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) -------------- @@ -269,8 +278,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 $ @@ -278,7 +290,11 @@ mkDataConIds wrap_name wkr_name data_con wrapNewTypeBody tycon res_ty_args (Var id_arg1) - id_arg1 = ASSERT( not (null orig_arg_tys) ) 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 @@ -286,8 +302,9 @@ 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 - dict_tys = mkPredTys theta - wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ + 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 @@ -317,6 +334,7 @@ mkDataConIds wrap_name wkr_name data_con 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) @@ -326,11 +344,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 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 @@ -473,31 +498,47 @@ gotten by appying the eq_spec to the univ_tvs of the data con. mkRecordSelId :: TyCon -> FieldLabel -> Id mkRecordSelId tycon field_label -- Assumes that all fields with the same field label have the same type - | is_naughty = naughty_id - | otherwise = sel_id + = sel_id where - is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set) + -- Because this function gets called by implicitTyThings, we need to + -- produce the OccName of the Id without doing any suspend type checks. + -- (see the note [Tricky iface loop]). + -- A suspended type-check is sometimes necessary to compute field_ty, + -- so we need to make sure that we suspend anything that depends on field_ty. + + -- the overall result + sel_id = mkGlobalId sel_id_details field_label theType theInfo + + -- check whether the type is naughty: this thunk does not get forced + -- until the type is actually needed + field_ty = dataConFieldType con1 field_label + is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set) + + -- it's important that this doesn't force the if + (theType, theInfo) = if is_naughty + -- Escapist case here for naughty constructors + -- We give it no IdInfo, and a type of forall a.a (never looked at) + then (forall_a_a, noCafIdInfo) + -- otherwise do the real case + else (selector_ty, info) + 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 + -- 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) - naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo + -- for naughty case forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - -- Normal case starts here - sel_id = mkGlobalId sel_id_details field_label selector_ty info + -- real case starts here: data_cons = tyConDataCons tycon data_cons_w_field = filter has_field data_cons -- Can't be empty! has_field con = field_label `elem` dataConFieldLabels con con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field - (univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1 + (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 -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over -- just the dictionaries in the types of the constructors that contain @@ -791,7 +832,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 @@ -813,16 +854,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}