From 29e736b7089d535b53e3f02ef04d36331921e42a Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:15:09 +0000 Subject: [PATCH] Fix problem with selectors for GADT records with unboxed fields Mon Sep 18 17:13:11 EDT 2006 Manuel M T Chakravarty * Fix problem with selectors for GADT records with unboxed fields Sun Aug 6 20:47:11 EDT 2006 Manuel M T Chakravarty * Fix problem with selectors for GADT records with unboxed fields Wed Aug 2 05:37:38 EDT 2006 kevind@bu.edu --- compiler/basicTypes/MkId.lhs | 4 ++-- compiler/coreSyn/CoreUtils.lhs | 28 +++++++++++++++++----------- compiler/iface/TcIface.lhs | 2 +- compiler/simplCore/Simplify.lhs | 4 ++-- 4 files changed, 22 insertions(+), 16 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 4609959..8df6aa7 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -59,7 +59,7 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta ) -import CoreUtils ( exprType, dataConInstPat ) +import CoreUtils ( exprType, dataConOrigInstPat ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) import Literal ( nullAddrLit, mkStringLit ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, @@ -563,7 +563,7 @@ mkRecordSelId tycon field_label -- in the types of the arguments of the pattern = (ex_tvs ++ co_tvs ++ dict_vs, field_vs) - (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys + (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat uniqs' data_con res_tys (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index b5ba2a2..76d742c 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -33,7 +33,7 @@ module CoreUtils ( -- Equality cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg, - dataConInstPat, dataConOccInstPat + dataConOrigInstPat, dataConRepInstPat, dataConRepOccInstPat ) where #include "HsVersions.h" @@ -57,7 +57,8 @@ import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) import DataCon ( DataCon, dataConRepArity, eqSpecPreds, isVanillaDataCon, dataConTyCon, dataConRepArgTys, - dataConUnivTyVars, dataConExTyVars, dataConEqSpec ) + dataConUnivTyVars, dataConExTyVars, dataConEqSpec, + dataConOrigArgTys ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, @@ -679,8 +680,13 @@ 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] -- A long enough list of uniques, at least one for each binder +-- 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 @@ -710,8 +716,8 @@ dataConInstPat :: [Unique] -- A long enough list of uniques, at -- ([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 uniqs con inst_tys - = dataConOccInstPat uniqs occs con inst_tys +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 @@ -719,7 +725,8 @@ dataConInstPat uniqs con inst_tys occs = mk_occs 1 mk_occs n = mkVarOcc ("ipv" ++ show n) : mk_occs (n+1) -dataConOccInstPat :: [Unique] -- A long enough list of uniques, at least one for each binder +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 @@ -727,12 +734,12 @@ dataConOccInstPat :: [Unique] -- A long enough list of uniques, -- 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 uniqs occs con inst_tys +dataConOccInstPat arg_fun uniqs occs con inst_tys = (ex_bndrs, co_bndrs, id_bndrs) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con - arg_tys = dataConRepArgTys con + arg_tys = arg_fun con eq_spec = dataConEqSpec con eq_preds = eqSpecPreds eq_spec @@ -1161,8 +1168,7 @@ eta_expand n us expr ty Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty')) where lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv) - (uniq:us2) = us - + (uniq:us2) = us ; Nothing -> case splitFunTy_maybe ty of { diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 051ec04..6d95d08 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, dataConOccInstPat ) +import CoreUtils ( exprType, dataConRepOccInstPat ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 0dde73d..f477038 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -45,7 +45,7 @@ import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprType, exprIsHNF, findDefault, mergeAlts, exprOkForSpeculation, exprArity, mkCoerce, mkSCC, mkInlineMe, applyTypeToArg, - dataConInstPat + dataConRepInstPat ) import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) @@ -1555,7 +1555,7 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs) do { tick (FillInCaseDefault case_bndr') ; us <- getUniquesSmpl ; let (ex_tvs, co_tvs, arg_ids) = - dataConInstPat us con inst_tys + dataConRepInstPat us con inst_tys ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs) ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt -- The simplAlt must succeed with Just because we have -- 1.7.10.4