Mon Sep 18 17:13:11 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* Fix problem with selectors for GADT records with unboxed fields
Sun Aug 6 20:47:11 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* Fix problem with selectors for GADT records with unboxed fields
Wed Aug 2 05:37:38 EDT 2006 kevind@bu.edu
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
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,
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
-- in the types of the arguments of the pattern
= (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
-- 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
(dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
(_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
-- Equality
cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
-- Equality
cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
- dataConInstPat, dataConOccInstPat
+ dataConOrigInstPat, dataConRepInstPat, dataConRepOccInstPat
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, eqSpecPreds,
isVanillaDataCon, dataConTyCon, dataConRepArgTys,
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,
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
-- coArgs = [right (left (left co)), right (left co), right co]
coArgs = decomposeCo (length 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
-> DataCon
-> [Type] -- Types to instantiate the universally quantified tyvars
-> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
-- ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b''])
--
-- where the double-primed variables are created from the unique list input
-- ([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
where
-- dataConOccInstPat doesn't actually make use of the OccName directly for
-- existential and coercion variable binders, so it is right to just
occs = mk_occs 1
mk_occs n = mkVarOcc ("ipv" ++ show n) : mk_occs (n+1)
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
-> [OccName] -- An equally long list of OccNames to use
-> DataCon
-> [Type] -- Types to instantiate the universally quantified tyvars
-- 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
-- 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
= (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 = eqSpecPreds eq_spec
eq_spec = dataConEqSpec con
eq_preds = eqSpecPreds eq_spec
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)
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)
; Nothing ->
case splitFunTy_maybe ty of {
; Nothing ->
case splitFunTy_maybe ty of {
emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
import InstEnv ( Instance(..), mkImportedInstance )
import CoreSyn
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 )
import CoreUnfold
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
do { tick (FillInCaseDefault case_bndr')
; us <- getUniquesSmpl
; let (ex_tvs, co_tvs, arg_ids) =
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
; 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