From cb41a80f4131b62ea383ba2635691c0e97738477 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:16:02 +0000 Subject: [PATCH] Just clean-up, no functional changes Mon Sep 18 17:14:51 EDT 2006 Manuel M T Chakravarty * Just clean-up, no functional changes Sun Aug 6 20:49:23 EDT 2006 Manuel M T Chakravarty * Just clean-up, no functional changes Wed Aug 2 06:48:44 EDT 2006 simonpj@microsoft.com --- compiler/basicTypes/MkId.lhs | 55 +++++++++++++++++++----------------------- 1 file changed, 25 insertions(+), 30 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index ba596e6..04f69f7 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -54,8 +54,8 @@ import HsBinds ( ExprCoFn(..), isIdCoercion ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, splitNewTypeRepCo_maybe, isEqPred ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, - mkTyConApp, mkTyVarTys, mkClassPred, - mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, + mkTyConApp, mkTyVarTys, mkClassPred, isPredTy, + mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta ) @@ -553,39 +553,34 @@ 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) rhs + ASSERT2( res_ty `tcEqType` field_tau, ppr data_con $$ ppr res_ty $$ ppr field_tau ) + mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs where - (arg_prefix, arg_ids) - = (ex_tvs ++ co_tvs ++ dict_vs, field_vs) - -- get pattern binders with types appropriately instantiated - (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat uniqs data_con res_tys - n_vars = (length ex_tvs + length co_tvs + length arg_vs) - -- separate dicts vars and field vars so we can associate field lbls - (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 - - arg_base' = arg_base + length dc_theta + arg_uniqs = map mkBuiltinUnique [arg_base..] + (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con res_tys - unpack_base = arg_base' + length dc_arg_tys + rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs + rebox_uniqs = map mkBuiltinUnique [rebox_base..] - uniq_list = map mkBuiltinUnique [unpack_base..] + -- data T :: *->* where T1 { fld :: Maybe b } -> T [b] + -- Hence T1 :: forall a b. (a=[b]) => b -> T a + -- fld :: forall b. T [b] -> Maybe b + -- fld = /\b.\(t:T[b]). case t of + -- T1 b' (c : [b]=[b']) (x:Maybe b') + -- -> x `cast` Maybe (sym (right c)) Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs - (co_fn, _) = refineType refinement (idType the_arg_id) - - rhs = 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 + (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) - -- split the uniq_list into two - uniqs = uniq_list - uniqs' = drop n_vars uniqs + rhs = case co_fn of + ExprCoFn co -> Cast (Var the_arg_id) co + id_co -> ASSERT(isIdCoercion id_co) Var the_arg_id - the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label + field_vs = filter (not . isPredTy . idType) arg_vs + the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label field_lbls = dataConFieldLabels data_con error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg @@ -611,7 +606,7 @@ unboxProduct i arg arg_ty body res_ty = result where result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs - (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty + (_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 @@ -641,7 +636,7 @@ reboxProduct :: [Unique] -- uniques to create new local binders [Id]) -- Ids being boxed into product reboxProduct us ty = let - (tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty + (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty us' = dropList con_arg_tys us @@ -656,7 +651,7 @@ mkProductBox :: [Id] -> Type -> CoreExpr mkProductBox arg_ids ty = result_expr where - (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty + (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty result_expr | isNewTyCon tycon && not (isRecursiveTyCon tycon) -- 1.7.10.4