From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:16:24 +0000 (+0000) Subject: make dataConInstPat take a list of FastStrings rather than OccNames, remove out-of... X-Git-Tag: After_FC_branch_merge~56 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=71cad0e1783707f325973a537b3b0a74300bd866 make dataConInstPat take a list of FastStrings rather than OccNames, remove out-of-date comment Mon Sep 18 17:15:25 EDT 2006 Manuel M T Chakravarty * make dataConInstPat take a list of FastStrings rather than OccNames, remove out-of-date comment Sun Aug 6 20:52:24 EDT 2006 Manuel M T Chakravarty * make dataConInstPat take a list of FastStrings rather than OccNames, remove out-of-date comment Wed Aug 2 09:26:47 EDT 2006 kevind@bu.edu --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 04f69f7..6c9029c 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -551,9 +551,7 @@ mkRecordSelId tycon field_label -- foo = /\a. \t:T. case t of { MkT f -> f a } 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 - ASSERT2( res_ty `tcEqType` field_tau, ppr data_con $$ ppr res_ty $$ ppr field_tau ) + = 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 -- get pattern binders with types appropriately instantiated diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 76d742c..b798379 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -33,7 +33,7 @@ module CoreUtils ( -- Equality cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg, - dataConOrigInstPat, dataConRepInstPat, dataConRepOccInstPat + dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat ) where #include "HsVersions.h" @@ -46,7 +46,7 @@ import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique, mkCoVar, mkTyVar, mkCoVar ) -import OccName ( OccName, occNameFS, mkVarOcc ) +import OccName ( OccName, occNameFS, mkVarOccFS ) import VarSet ( unionVarSet ) import VarEnv import Name ( hashName, mkSysTvName ) @@ -88,7 +88,7 @@ import Outputable import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt ) import TysPrim ( alphaTy ) -- Debugging only import Util ( equalLength, lengthAtLeast, foldl2 ) -import FastString ( mkFastString ) +import FastString ( FastString ) \end{code} @@ -681,16 +681,18 @@ deepCast ty tyVars co coArgs = decomposeCo (length tyVars) co -- These InstPat functions go here to avoid circularity between DataCon and Id -dataConOrigInstPat = dataConInstPat dataConOrigArgTys -dataConRepInstPat = dataConInstPat dataConRepArgTys -dataConRepOccInstPat = dataConOccInstPat dataConRepArgTys - -dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys - -> [Unique] -- A long enough list of uniques, at least one for each binder - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables --- dataConInstPat us con inst_tys returns a triple (ex_tvs, co_tvs, arg_ids), +dataConOrigInstPat = dataConInstPat dataConOrigArgTys (repeat (FSLIT("ipv"))) +dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv"))) +dataConRepFSInstPat = dataConInstPat dataConRepArgTys + +dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys + -> [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun us fss con inst_tys returns a triple +-- (ex_tvs, co_tvs, arg_ids), -- -- ex_tvs are intended to be used as binders for existential type args -- @@ -716,25 +718,8 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys -- ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b'']) -- -- where the double-primed variables are created from the unique list input -dataConInstPat arg_fun uniqs con inst_tys - = dataConOccInstPat arg_fun uniqs occs con inst_tys - where - -- dataConOccInstPat doesn't actually make use of the OccName directly for - -- existential and coercion variable binders, so it is right to just - -- use the VarName namespace for all of the OccNames - occs = mk_occs 1 - mk_occs n = mkVarOcc ("ipv" ++ show n) : mk_occs (n+1) - -dataConOccInstPat :: (DataCon -> [Type]) -- function used to find arg tys - -> [Unique] -- A long enough list of uniques, at least one for each binder - -> [OccName] -- An equally long list of OccNames to use - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables --- This function actually does the job specified in the comment for --- dataConInstPat, but uses the specified list of OccNames. This is --- is necessary for use in e.g. tcIfaceDataAlt -dataConOccInstPat arg_fun uniqs occs con inst_tys +-- getting names from the FS list input +dataConInstPat arg_fun fss uniqs con inst_tys = (ex_bndrs, co_bndrs, id_bndrs) where univ_tvs = dataConUnivTyVars con @@ -747,34 +732,34 @@ dataConOccInstPat arg_fun uniqs occs con inst_tys n_co = length eq_spec n_id = length arg_tys - -- split the Uniques and OccNames + -- split the Uniques and FastStrings (ex_uniqs, uniqs') = splitAt n_ex uniqs (co_uniqs, id_uniqs) = splitAt n_co uniqs' - (ex_occs, occs') = splitAt n_ex occs - (co_occs, id_occs) = splitAt n_co occs' + (ex_fss, fss') = splitAt n_ex fss + (co_fss, id_fss) = splitAt n_co fss' -- make existential type variables - mk_ex_var uniq occ var = mkTyVar new_name kind + mk_ex_var uniq fs var = mkTyVar new_name kind where - new_name = mkSysTvName uniq (occNameFS occ) + new_name = mkSysTvName uniq fs kind = tyVarKind var - ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_occs ex_tvs + ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs -- make the instantiation substitution inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) -- make new coercion vars, instantiating kind - mk_co_var uniq occ eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred)) + mk_co_var uniq fs eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred)) where - new_name = mkSysTvName uniq (occNameFS occ) + new_name = mkSysTvName uniq fs - co_bndrs = zipWith3 mk_co_var co_uniqs co_occs eq_preds + co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds -- make value vars, instantiating types - mk_id_var uniq occ ty = mkUserLocal occ uniq (inst_subst ty) noSrcLoc - id_bndrs = zipWith3 mk_id_var id_uniqs id_occs arg_tys + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (inst_subst ty) noSrcLoc + id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -- Returns (Just (dc, [x1..xn])) if the argument expression is diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6d95d08..90bedd9 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, dataConRepOccInstPat ) +import CoreUtils ( exprType, dataConRepFSInstPat ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) @@ -53,7 +53,7 @@ import Var ( TyVar, mkTyVar, tyVarKind ) import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, nameOccName, wiredInNameTyThing_maybe ) import NameEnv -import OccName ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace ) +import OccName ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace, occNameFS ) import FastString ( FastString ) import Module ( Module, moduleName ) import UniqFM ( lookupUFM ) @@ -680,7 +680,7 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, co_tvs, arg_ids) = dataConOccInstPat uniqs arg_occs con inst_tys + ; let (ex_tvs, co_tvs, arg_ids) = dataConRepFSInstPat (map occNameFS arg_strs) uniqs con inst_tys all_tvs = ex_tvs ++ co_tvs ; rhs' <- extendIfaceTyVarEnv all_tvs $