X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=de8db07c6dac0d130407e7a79bc9f7a8f1bdb9fe;hb=8912a05e1bcc30c7e8e5e017d9cf10176076f141;hp=2373d726fe72a9143c4a22f46a55ee7d36b9c221;hpb=a6cbfa877c81ef3563d267a35faeb9633ef3000a;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 2373d72..de8db07 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -26,7 +26,7 @@ module MkId ( -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, - lazyId, lazyIdUnfolding, lazyIdKey, + lazyId, lazyIdUnfolding, lazyIdKey, mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, @@ -46,31 +46,36 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, ) import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) -import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs ) +import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType, + PredType(..), + mkTopTvSubst, substTyVar ) +import TcGadt ( gadtRefine, refineType, emptyRefinement ) +import HsBinds ( ExprCoFn(..), isIdCoercion ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, - splitRecNewTypeCo_maybe ) + splitNewTypeRepCo_maybe, isEqPred ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, mkTyConApp, mkTyVarTys, mkClassPred, mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta ) -import CoreUtils ( exprType ) +import CoreUtils ( exprType, dataConInstPat ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) import Literal ( nullAddrLit, mkStringLit ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon, newTyConCo, tyConArity ) import Class ( Class, classTyCon, classSelIds ) -import Var ( Id, TyVar, Var ) +import Var ( Id, TyVar, Var, setIdType, mkCoVar, mkWildCoVar ) import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) -import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) +import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..), + mkSysTvName ) import OccName ( mkOccNameFS, varName ) import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars, dataConFieldLabels, dataConRepArity, dataConResTys, - dataConRepArgTys, dataConRepType, + dataConRepArgTys, dataConRepType, dataConFullSig, dataConSig, dataConStrictMarks, dataConExStricts, splitProductType, isVanillaDataCon, dataConFieldType, dataConInstOrigArgTys, deepSplitProductType @@ -95,7 +100,7 @@ import PrelNames import Util ( dropList, isSingleton ) import Outputable import FastString -import ListSetOps ( assoc ) +import ListSetOps ( assoc, minusList ) \end{code} %************************************************************************ @@ -193,24 +198,28 @@ mkDataConIds wrap_name wkr_name data_con = NewDC nt_wrap_id | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper + || not (null eq_spec) = AlgDC (Just alg_wrap_id) wrk_id | otherwise -- Algebraic, no wrapper = AlgDC Nothing wrk_id where - (tvs, theta, orig_arg_tys) = dataConSig data_con - tycon = dataConTyCon data_con + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con + tycon = dataConTyCon data_con - dict_tys = mkPredTys theta - all_arg_tys = dict_tys ++ orig_arg_tys - tycon_args = dataConUnivTyVars data_con - result_ty_args = (mkTyVarTys tycon_args) - result_ty = mkTyConApp tycon result_ty_args - - wrap_ty = mkForAllTys tvs (mkFunTys all_arg_tys result_ty) + ----------- 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 + subst = mkTopTvSubst eq_spec + dict_tys = mkPredTys theta + result_ty_args = map (substTyVar subst) univ_tvs + result_ty = mkTyConApp tycon result_ty_args + wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ + mkFunTys orig_arg_tys $ result_ty + -- NB: watch out here if you allow user-written equality + -- constraints in data constructor signatures ----------- Worker (algebraic data types only) -------------- -- The *worker* for the data constructor is the function that @@ -260,7 +269,7 @@ mkDataConIds wrap_name wkr_name data_con -- No existentials on a newtype, but it can have a context -- e.g. newtype Eq a => T a = MkT (...) mkCompulsoryUnfolding $ - mkLams tvs $ Lam id_arg1 $ + mkLams wrap_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon result_ty_args (Var id_arg1) @@ -290,14 +299,16 @@ mkDataConIds wrap_name wkr_name data_con -- we want to see that w is strict in its two arguments alg_unf = mkTopUnfolding $ Note InlineMe $ - mkLams tvs $ + mkLams wrap_tvs $ mkLams dict_args $ mkLams id_args $ foldr mk_case con_app (zip (dict_args ++ id_args) all_strict_marks) i3 [] - con_app i rep_ids = mkApps (Var wrk_id) - (map varToCoreExpr (tvs ++ reverse rep_ids)) + con_app i rep_ids = Var wrk_id `mkTyApps` result_ty_args + `mkVarApps` ex_tvs + `mkTyApps` map snd eq_spec + `mkVarApps` reverse rep_ids (dict_args,i2) = mkLocals 1 dict_tys (id_args,i3) = mkLocals i2 orig_arg_tys @@ -461,7 +472,9 @@ mkRecordSelId tycon field_label stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field) n_stupid_dicts = length stupid_dict_tys - (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty + (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty + + field_theta = filter (not . isEqPred) pre_field_theta field_dict_tys = mkPredTys field_theta n_field_dict_tys = length field_dict_tys -- If the field has a universally quantified type we have to @@ -540,21 +553,42 @@ mkRecordSelId tycon field_label mk_alt data_con = -- In the non-vanilla case, the pattern must bind type variables and -- the context stuff; hence the arg_prefix binding below - mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id) + mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) rhs where (arg_prefix, arg_ids) | isVanillaDataCon data_con -- Instantiate from commmon base = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys)) | otherwise -- The case pattern binds type variables, which are used -- in the types of the arguments of the pattern - = (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta), - mkTemplateLocalsNum arg_base' dc_arg_tys) + = (ex_tvs ++ co_tvs ++ dict_vs, field_vs) + + (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys + (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs + + (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con + dc_theta = filter (not . isEqPred) pre_dc_theta - (dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con arg_base' = arg_base + length dc_theta unpack_base = arg_base' + length dc_arg_tys - uniqs = map mkBuiltinUnique [unpack_base..] + + uniq_list = map mkBuiltinUnique [unpack_base..] + + Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs + (co_fn, out_ty) = refineType refinement (idType the_arg_id) + + rhs = ASSERT(out_ty `coreEqType` field_tau) perform_co co_fn (Var the_arg_id) + + perform_co (ExprCoFn co) expr = Cast expr co + perform_co id_co expr = ASSERT(isIdCoercion id_co) expr + + -- split the uniq_list into two + uniqs = takeHalf uniq_list + uniqs' = takeHalf (drop 1 uniq_list) + + takeHalf [] = [] + takeHalf (h:_:t) = h:(takeHalf t) + takeHalf (h:t) = [h] the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label field_lbls = dataConFieldLabels data_con @@ -579,27 +613,30 @@ mkRecordSelId tycon field_label -- The Ints passed around are just for creating fresh locals unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr unboxProduct i arg arg_ty body res_ty - = mkUnpackCase the_id arg con_args boxing_con rhs + = result where - (_, _, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty + result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs + (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty ([the_id], i') = mkLocals i [arg_ty] (con_args, i'') = mkLocals i' tys rhs = body i'' con_args -mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr +mkUnpackCase :: Id -> CoreExpr -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr -- (mkUnpackCase x e args Con body) -- returns -- case (e `cast` ...) of bndr { Con args -> body } -mkUnpackCase bndr arg unpk_args boxing_con body - = Case cast_arg bndr (exprType body) [(DataAlt boxing_con, unpk_args, body)] +-- +-- the type of the bndr passed in is irrelevent +mkUnpackCase bndr arg arg_ty unpk_args boxing_con body + = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)] where - cast_arg = go (idType bndr) arg + (cast_arg, bndr_ty) = go (idType bndr) arg go ty arg | res@(tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty , isNewTyCon tycon && not (isRecursiveTyCon tycon) = go (newTyConInstRhs tycon tycon_args) (unwrapNewTypeBody tycon tycon_args arg) - | otherwise = arg + | otherwise = (arg, ty) -- ...and the dual reboxProduct :: [Unique] -- uniques to create new local binders @@ -627,7 +664,7 @@ mkProductBox arg_ids ty (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty result_expr - | isNewTyCon tycon + | isNewTyCon tycon && not (isRecursiveTyCon tycon) = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args)) | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids)