Commit ef47b5c2 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

fixing record selectors

Mon Sep 18 16:50:18 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * fixing record selectors
  Sun Aug  6 19:56:29 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * 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
parent e380d180
......@@ -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,
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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)
......
......@@ -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') }
......
......@@ -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')
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment