From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 17:49:47 +0000 (+0000) Subject: fixing record selectors X-Git-Tag: After_FC_branch_merge~71 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ef47b5c2f44fce638b623c9cf5bb2f7f62ba619d fixing record selectors Mon Sep 18 16:50:18 EDT 2006 Manuel M T Chakravarty * fixing record selectors Sun Aug 6 19:56:29 EDT 2006 Manuel M T Chakravarty * fixing record selectors Fri Jul 28 10:24:28 EDT 2006 kevind@bu.edu - Bad conflict in tcIfaceDataAlt, at a place where the monster patch had a conflict, too. I have no idea what the right code is. -=chak NB (at time of 2nd merge): previous conflict resolution was fine --- diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 2fc8024..5da66d9 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -33,15 +33,16 @@ import Type ( Type, ThetaType, substTyWith, substTyVar, mkTopTvSubst, mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, splitTyConApp_maybe, newTyConInstRhs, - mkPredTys, isStrictPred, pprType + mkPredTys, isStrictPred, pprType, mkPredTy ) import Coercion ( isEqPred, mkEqPred ) import TyCon ( TyCon, FieldLabel, tyConDataCons, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isNewTyCon, isRecursiveTyCon ) import Class ( Class, classTyCon ) -import Name ( Name, NamedThing(..), nameUnique ) -import Var ( TyVar, Id ) +import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName ) ++ import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique, ++ mkCoVar ) import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) @@ -49,6 +50,7 @@ import ListSetOps ( assoc, minusList ) import Util ( zipEqual, zipWithEqual ) import List ( partition ) import Maybes ( expectJust ) +import FastString \end{code} @@ -602,6 +604,7 @@ dataConInstArgTys (MkData {dcRepArgTys = arg_tys, where tyvars = univ_tvs ++ ex_tvs + -- And the same deal for the original arg tys dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index e14e47a..c9c503d 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -160,13 +160,14 @@ mkLocalId :: Name -> Type -> Id mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo -- SysLocal: for an Id being created by the compiler out of thin air... +mkSysLocal :: FastString -> Unique -> Type -> Id +mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty + + -- UserLocal: an Id with a name the user might recognize... mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id -mkSysLocal :: FastString -> Unique -> Type -> Id mkVanillaGlobal :: Name -> Type -> IdInfo -> Id -mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty - mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkVanillaGlobal = mkGlobalId VanillaGlobal \end{code} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 5fe7dc0..f912731 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -49,6 +49,8 @@ import PrelRules ( primOpRules ) import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType, PredType(..), mkTopTvSubst, substTyVar ) +import TcGadt ( gadtRefine, refineType, emptyRefinement ) +import HsBinds ( ExprCoFn(..), isIdCoercion ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, splitNewTypeRepCo_maybe, isEqPred ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, @@ -57,16 +59,17 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 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, setIdType, mkWildCoVar ) +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 ) @@ -469,13 +472,12 @@ mkRecordSelId tycon field_label stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field) n_stupid_dicts = length stupid_dict_tys - (pre_field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty - -- tcSplitSigmaTy puts tyvars with EqPred kinds in with the theta, but - -- this is not what we want here, so we need to split out the EqPreds - -- as new wild tyvars - field_tyvars = pre_field_tyvars ++ eq_vars - eq_vars = map (mkWildCoVar . mkPredTy) + (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty + + mk_co_var k = mkWildCoVar k + eq_vars = map (mk_co_var . mkPredTy) (filter isEqPred pre_field_theta) + field_theta = filter (not . isEqPred) pre_field_theta field_dict_tys = mkPredTys field_theta n_field_dict_tys = length field_dict_tys @@ -555,30 +557,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) - - (pre_dc_tvs, pre_dc_theta, dc_arg_tys) = dataConSig data_con - -- again we need to pull the EqPreds out of dc_theta, into dc_tvs - dc_eqvars = map (mkWildCoVar . mkPredTy . fixEqPred) (filter isEqPred pre_dc_theta) - -- The type of the record selector Id does not contain the univ tvs - -- but rather their substitution according to the eq_spec. Therefore - -- the coercion arguments bound in the case alternative will just - -- have reflexive coercion kinds - fixEqPred (EqPred ty1 ty2) = EqPred ty2 ty2 - dc_tvs = drop (length (dataConUnivTyVars data_con)) pre_dc_tvs ++ dc_eqvars + = (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 + 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 diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index f98fdae..017e355 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -22,7 +22,7 @@ module Var ( Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo, - setIdExported, setIdNotExported, + setIdExported, setIdNotExported, globalIdDetails, globaliseId, @@ -40,12 +40,14 @@ import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo ) import Name ( Name, NamedThing(..), - setNameUnique, nameUnique, mkSysTvName + setNameUnique, nameUnique, mkSysTvName, + mkSystemVarName ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey#, mkBuiltinUnique ) import FastTypes -import Outputable +import FastString +import Outputable \end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index a147ce2..31a52f0 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -500,7 +500,7 @@ lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ lintBinders args $ \ args -> + = lintBinders args $ \ args -> do { addLoc (CasePat alt) $ do { -- Check the pattern diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 0077183..af44ef4 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -31,7 +31,9 @@ module CoreUtils ( hashExpr, -- Equality - cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg + cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg, + + dataConInstPat ) where #include "HsVersions.h" @@ -42,10 +44,11 @@ import GLAEXTS -- For `xori` import CoreSyn import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) -import Var ( Var, TyVar, isCoVar, tyVarKind ) +import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique, + mkCoVar, mkTyVar, mkCoVar ) import VarSet ( unionVarSet ) import VarEnv -import Name ( hashName ) +import Name ( hashName, mkSysTvName ) #if mingw32_TARGET_OS import Packages ( isDllName ) #endif @@ -53,7 +56,7 @@ import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) import DataCon ( DataCon, dataConRepArity, isVanillaDataCon, dataConTyCon, dataConRepArgTys, - dataConUnivTyVars, dataConExTyVars ) + dataConUnivTyVars, dataConExTyVars, dataConEqSpec ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, @@ -67,12 +70,12 @@ import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, applyTys, isUnLiftedType, seqType, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, splitTyConApp_maybe, coreEqType, funResultTy, applyTy, - substTyWith + substTyWith, mkPredTy ) import Coercion ( Coercion, mkTransCoercion, coercionKind, splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion, mkRightCoercion, decomposeCo, coercionKindPredTy, - splitCoercionKind ) + splitCoercionKind, mkEqPred ) import TyCon ( tyConArity ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) @@ -674,6 +677,48 @@ deepCast ty tyVars co -- coArgs = [right (left (left co)), right (left co), right co] coArgs = decomposeCo (length tyVars) co +-- This goes here to avoid circularity between DataCon and Id +dataConInstPat :: [Unique] -- An infinite list of uniques + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables +dataConInstPat uniqs con inst_tys + = (ex_bndrs, co_bndrs, id_bndrs) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyVars con + arg_tys = dataConRepArgTys con + eq_spec = dataConEqSpec con + eq_preds = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- eq_spec ] + + n_ex = length ex_tvs + n_co = length eq_spec + n_id = length arg_tys + + -- split the uniques + (ex_uniqs, uniqs') = splitAt n_ex uniqs + (co_uniqs, id_uniqs) = splitAt n_co uniqs' + + -- make existential type variables + mk_ex_var uniq var = setVarUnique var uniq + ex_bndrs = zipWith mk_ex_var ex_uniqs ex_tvs + + -- make the instantiation substitution + inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) + + -- make a new coercion vars, instantiating kind + mk_co_var uniq eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred)) + where + new_name = mkSysTvName uniq FSLIT("co") + + co_bndrs = zipWith mk_co_var co_uniqs eq_preds + + -- make value vars, instantiating types + mk_id_var uniq ty = mkSysLocal FSLIT("ca") uniq (inst_subst ty) + + id_bndrs = zipWith mk_id_var id_uniqs arg_tys + + exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -- Returns (Just (dc, [x1..xn])) if the argument expression is -- a constructor application of the form (dc x1 .. xn) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 04154ef..94e0dcb 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -35,7 +35,7 @@ import HscTypes ( ExternalPackageState(..), emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( Instance(..), mkImportedInstance ) import CoreSyn -import CoreUtils ( exprType ) +import CoreUtils ( exprType, dataConInstPat ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) @@ -57,7 +57,7 @@ import OccName ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace ) import FastString ( FastString ) import Module ( Module, moduleName ) import UniqFM ( lookupUFM ) -import UniqSupply ( initUs_ ) +import UniqSupply ( initUs_, uniqsFromSupply ) import Outputable import ErrUtils ( Message ) import Maybes ( MaybeErr(..) ) @@ -678,18 +678,12 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } tcIfaceDataAlt con inst_tys arg_strs rhs - = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs) - ; let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs - ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs - ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs - ; let ex_tvs = [ mkTyVar name (tyVarKind tv) - | (name,tv) <- tyvar_names `zip` dataConExTyVars con ] - arg_tys = dataConInstArgTys con (inst_tys ++ mkTyVarTys ex_tvs) - arg_ids = ASSERT2( equalLength id_names arg_tys, - ppr (con, tyvar_names++id_names, rhs) $$ ppr ex_tvs $$ ppr arg_tys ) - zipWith mkLocalId id_names arg_tys - - ; rhs' <- extendIfaceTyVarEnv ex_tvs $ + = do { us <- newUniqueSupply + ; let uniqs = uniqsFromSupply us + ; let (ex_tvs, co_tvs, arg_ids) = dataConInstPat uniqs con inst_tys + all_tvs = ex_tvs ++ co_tvs + + ; rhs' <- extendIfaceTyVarEnv all_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } diff --git a/compiler/typecheck/TcGadt.lhs b/compiler/typecheck/TcGadt.lhs index 4de2634..deac1eb 100644 --- a/compiler/typecheck/TcGadt.lhs +++ b/compiler/typecheck/TcGadt.lhs @@ -387,21 +387,21 @@ uUnrefined subst co tv1 ty2 (TyVarTy tv2) = do { b1 <- tvBindFlag tv1 ; b2 <- tvBindFlag tv2 ; case (b1,b2) of - (BindMe, _) -> bind tv1 ty2 + (BindMe, _) -> bind False tv1 ty2 - (AvoidMe, BindMe) -> bind tv2 ty1 - (AvoidMe, _) -> bind tv1 ty2 + (AvoidMe, BindMe) -> bind True tv2 ty1 + (AvoidMe, _) -> bind False tv1 ty2 (WildCard, WildCard) -> return subst (WildCard, Skolem) -> return subst - (WildCard, _) -> bind tv2 ty1 + (WildCard, _) -> bind True tv2 ty1 (Skolem, WildCard) -> return subst (Skolem, Skolem) -> failWith (misMatch ty1 ty2) - (Skolem, _) -> bind tv2 ty1 + (Skolem, _) -> bind True tv2 ty1 } - | k1 `isSubKind` k2 = bindTv subst co tv2 ty1 -- Must update tv2 + | k1 `isSubKind` k2 = bindTv subst (mkSymCoercion co) tv2 ty1 -- Must update tv2 | k2 `isSubKind` k1 = bindTv subst co tv1 ty2 -- Must update tv1 | otherwise = failWith (kindMisMatch tv1 ty2) @@ -409,7 +409,9 @@ uUnrefined subst co tv1 ty2 (TyVarTy tv2) ty1 = TyVarTy tv1 k1 = tyVarKind tv1 k2 = tyVarKind tv2 - bind tv ty = return (extendVarEnv subst tv (co,ty)) + bind swap tv ty = return (extendVarEnv subst tv (co',ty)) + where + co' = if swap then mkSymCoercion co else co uUnrefined subst co tv1 ty2 ty2' -- ty2 is not a type variable | tv1 `elemVarSet` substTvSet subst (tyVarsOfType ty2')