diff options
Diffstat (limited to 'ghc/compiler/iface')
| -rw-r--r-- | ghc/compiler/iface/BinIface.hs | 60 | ||||
| -rw-r--r-- | ghc/compiler/iface/BuildTyCl.lhs | 189 | ||||
| -rw-r--r-- | ghc/compiler/iface/IfaceEnv.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/iface/IfaceSyn.lhs | 199 | ||||
| -rw-r--r-- | ghc/compiler/iface/IfaceType.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/iface/LoadIface.lhs | 29 | ||||
| -rw-r--r-- | ghc/compiler/iface/MkIface.lhs | 12 | ||||
| -rw-r--r-- | ghc/compiler/iface/TcIface.lhs | 184 |
8 files changed, 375 insertions, 306 deletions
diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index a0e932ed88..286c612dfb 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -693,10 +693,13 @@ instance Binary IfaceExpr where putByte bh 4 put_ bh ag put_ bh ah - put_ bh (IfaceCase ai aj ak) = do +-- gaw 2004 + put_ bh (IfaceCase ai aj al ak) = do putByte bh 5 put_ bh ai put_ bh aj +-- gaw 2004 + put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do putByte bh 6 @@ -734,8 +737,11 @@ instance Binary IfaceExpr where return (IfaceApp ag ah) 5 -> do ai <- get bh aj <- get bh +-- gaw 2004 + al <- get bh ak <- get bh - return (IfaceCase ai aj ak) +-- gaw 2004 + return (IfaceCase ai aj al ak) 6 -> do al <- get bh am <- get bh return (IfaceLet al am) @@ -874,7 +880,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -882,7 +888,6 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 put_ bh a6 - put_ bh a7 put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 @@ -914,8 +919,7 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - a7 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7) + return (IfaceData a1 a2 a3 a4 a5 a6) 3 -> do aq <- get bh ar <- get bh @@ -942,37 +946,53 @@ instance Binary IfaceInst where instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = do { putByte bh 1 - ; put_ bh cs } + put_ bh (IfDataTyCon st cs) = do { putByte bh 1 + ; put_ bh st + ; put_ bh cs } put_ bh (IfNewTyCon c) = do { putByte bh 2 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> do aa <- get bh - return (IfDataTyCon aa) + 1 -> do st <- get bh + cs <- get bh + return (IfDataTyCon st cs) _ -> do aa <- get bh return (IfNewTyCon aa) instance Binary IfaceConDecl where - put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do + putByte bh 0 + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do + putByte bh 1 put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 - put_ bh a7 get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - return (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) + h <- getByte bh + case h of + 0 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfVanillaCon a1 a2 a3 a4 a5) + _ -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfGadtCon a1 a2 a3 a4 a5 a6) instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do diff --git a/ghc/compiler/iface/BuildTyCl.lhs b/ghc/compiler/iface/BuildTyCl.lhs index 862af64665..8624ff9349 100644 --- a/ghc/compiler/iface/BuildTyCl.lhs +++ b/ghc/compiler/iface/BuildTyCl.lhs @@ -14,12 +14,11 @@ module BuildTyCl ( import IfaceEnv ( newImplicitBinder ) import TcRnMonad -import Subst ( substTyWith ) import Util ( zipLazy ) -import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName ) -import VarSet -import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels ) +import DataCon ( DataCon, isNullarySrcDataCon, + mkDataCon, dataConFieldLabels, dataConOrigArgTys ) import Var ( tyVarKind, TyVar, Id ) +import VarSet ( isEmptyVarSet, intersectVarSet ) import TysWiredIn ( unitTy ) import BasicTypes ( RecFlag, StrictnessMark(..) ) import Name ( Name ) @@ -27,11 +26,12 @@ import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc ) import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) -import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, +import TyCon ( FieldLabel, mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons ) -import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind, - tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type ) +import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred, + splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type, + substTyWith, zipTopTvSubst, substTheta ) import Outputable import List ( nubBy ) @@ -47,17 +47,17 @@ buildSynTyCon name tvs rhs_ty arg_vrcs ------------------------------------------------------ -buildAlgTyCon :: Name -> [TyVar] -> ThetaType +buildAlgTyCon :: Name -> [TyVar] -> AlgTyConRhs -> ArgVrcs -> RecFlag -> Bool -- True <=> want generics functions -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics - = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs - rhs sel_ids is_rec want_generics +buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics + = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs + rhs fields is_rec want_generics ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; sel_ids = mkRecordSelectors tycon rhs + ; fields = mkTyConFields tycon rhs } ; return tycon } @@ -65,37 +65,63 @@ buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs cons - = DataTyCon cons (all is_nullary cons) +mkDataTyConRhs :: Maybe ThetaType -> [DataCon] -> AlgTyConRhs +mkDataTyConRhs mb_theta cons + = DataTyCon mb_theta cons (all isNullarySrcDataCon cons) + +mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs +mkNewTyConRhs tycon con + = NewTyCon con rhs_ty (mkNewTyConRep tycon) where - is_nullary con = null (dataConOrigArgTys con) - -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon - -- but that looks at the *representation* arity, and isEnumerationType - -- refers to the *source* code definition - -mkNewTyConRhs :: DataCon -> AlgTyConRhs -mkNewTyConRhs con - = NewTyCon con -- The constructor - (head (dataConOrigArgTys con)) -- The RHS type - (mkNewTyConRep (dataConTyCon con)) -- The ultimate rep type + rhs_ty = head (dataConOrigArgTys con) + -- Newtypes are guaranteed vanilla, so OrigArgTys will do +mkNewTyConRep :: TyCon -- The original type constructor + -> Type -- Chosen representation type + -- (guaranteed not to be another newtype) + +-- Find the representation type for this newtype TyCon +-- Remember that the representation type is the *ultimate* representation +-- type, looking through other newtypes. +-- +-- The non-recursive newtypes are easy, because they look transparent +-- to splitTyConApp_maybe, but recursive ones really are represented as +-- TyConApps (see TypeRep). +-- +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T + +mkNewTyConRep tc + | null (tyConDataCons tc) = unitTy + -- External Core programs can have newtypes with no data constructors + | otherwise = go [] tc + where + -- Invariant: tc is a NewTyCon + -- tcs have been seen before + go tcs tc + | tc `elem` tcs = unitTy + | otherwise + = case splitTyConApp_maybe rhs_ty of + Just (tc', tys) | isNewTyCon tc' + -> substTyWith tc_tvs tys (go (tc:tcs) tc') + other -> rhs_ty + where + (tc_tvs, rhs_ty) = newTyConRhs tc + ------------------------------------------------------ -buildDataCon :: Name -> Bool +buildDataCon :: Name -> Bool -> Bool -> [StrictnessMark] -> [Name] -- Field labels -> [TyVar] -> ThetaType - -> [TyVar] -> ThetaType - -> [Type] -> TyCon + -> [Type] -> TyCon -> [Type] -> TcRnIf m n DataCon -- A wrapper for DataCon.mkDataCon that -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) -buildDataCon src_name declared_infix arg_stricts field_lbl_names - tyvars ctxt ex_tyvars ex_ctxt - arg_tys tycon +buildDataCon src_name declared_infix vanilla arg_stricts field_lbls + tyvars ctxt arg_tys tycon res_tys = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc -- This last one takes the name of the data constructor in the source @@ -103,43 +129,44 @@ buildDataCon src_name declared_infix arg_stricts field_lbl_names -- space, and makes it into a "real data constructor name" ; let - -- Make the FieldLabels - -- The zipLazy avoids forcing the arg_tys too early - final_lbls = [ mkFieldLabel name tycon ty tag - | ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags) - `zipLazy` arg_tys - ] - - ctxt' = thinContext arg_tys ctxt - data_con = mkDataCon src_name declared_infix - arg_stricts final_lbls - tyvars ctxt' - ex_tyvars ex_ctxt - arg_tys tycon dc_ids + stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys + data_con = mkDataCon src_name declared_infix vanilla + arg_stricts field_lbls + tyvars stupid_ctxt ctxt + arg_tys tycon res_tys dc_ids dc_ids = mkDataConIds wrap_name work_name data_con ; returnM data_con } --- The context for a data constructor should be limited to + +-- The stupid context for a data constructor should be limited to -- the type variables mentioned in the arg_tys -thinContext arg_tys ctxt - = filter in_arg_tys ctxt +mkDataConStupidTheta tycon arg_tys res_tys + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta where - arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ + tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + arg_tyvars = tyVarsOfTypes arg_tys + in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfPred pred `intersectVarSet` arg_tyvars ------------------------------------------------------ -mkRecordSelectors :: TyCon -> AlgTyConRhs -> [Id] -mkRecordSelectors tycon data_cons +mkTyConFields :: TyCon -> AlgTyConRhs -> [(FieldLabel,Type,Id)] +mkTyConFields tycon rhs = -- We'll check later that fields with the same name -- from different constructors have the same type. - [ mkRecordSelId tycon field - | field <- nubBy eq_name fields ] + [ (fld, ty, mkRecordSelId tycon fld ty) + | (fld, ty) <- nubBy eq_fld all_fld_tys ] where - fields = [ field | con <- visibleDataCons data_cons, - field <- dataConFieldLabels con ] - eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2 + all_fld_tys = concatMap fld_tys_of (visibleDataCons rhs) + fld_tys_of con = dataConFieldLabels con `zipLazy` + dataConOrigArgTys con + -- The laziness means that the type isn't sucked in prematurely + -- Only vanilla datacons have fields at all, and they + -- share the tycon's type variables => datConOrigArgTys will do + + eq_fld (f1,_) (f2,_) = f1 == f2 \end{code} @@ -177,13 +204,13 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs | (op_name, dm_info, _) <- sig_stuff ] } -- Build the selector id and default method id - ; dict_con <- buildDataCon datacon_name False {- Not declared infix -} + ; dict_con <- buildDataCon datacon_name + False -- Not declared infix + True -- Is vanilla; tyvars same as tycon (map (const NotMarkedStrict) dict_component_tys) [{- No labelled fields -}] - tvs [{-No context-}] - [{-No existential tyvars-}] [{-Or context-}] - dict_component_tys - (classTyCon clas) + tvs [{-No context-}] dict_component_tys + (classTyCon clas) (mkTyVarTys tvs) ; let { clas = mkClass class_name tvs fds sc_theta sc_sel_ids op_items @@ -202,47 +229,11 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs ; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; rhs = case dict_component_tys of - [rep_ty] -> mkNewTyConRhs dict_con - other -> mkDataTyConRhs [dict_con] + [rep_ty] -> mkNewTyConRhs tycon dict_con + other -> mkDataTyConRhs Nothing [dict_con] } ; return clas })} \end{code} ------------------------------------------------------- -\begin{code} -mkNewTyConRep :: TyCon -- The original type constructor - -> Type -- Chosen representation type - -- (guaranteed not to be another newtype) - --- Find the representation type for this newtype TyCon --- Remember that the representation type is the *ultimate* representation --- type, looking through other newtypes. --- --- The non-recursive newtypes are easy, because they look transparent --- to splitTyConApp_maybe, but recursive ones really are represented as --- TyConApps (see TypeRep). --- --- The trick is to to deal correctly with recursive newtypes --- such as newtype T = MkT T - -mkNewTyConRep tc - | null (tyConDataCons tc) = unitTy - -- External Core programs can have newtypes with no data constructors - | otherwise = go [] tc - where - -- Invariant: tc is a NewTyCon - -- tcs have been seen before - go tcs tc - | tc `elem` tcs = unitTy - | otherwise - = case splitTyConApp_maybe rep_ty of - Nothing -> rep_ty - Just (tc', tys) | not (isNewTyCon tc') -> rep_ty - | otherwise -> go1 (tc:tcs) tc' tys - where - (_,rep_ty) = newTyConRhs tc - - go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) -\end{code} diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 9e88ee9301..6922ac9a96 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -18,10 +18,8 @@ module IfaceEnv ( import TcRnMonad import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) -import HscTypes ( NameCache(..), HscEnv(..), - TyThing, ExternalPackageState(..), OrigNameCache ) +import HscTypes ( NameCache(..), HscEnv(..), OrigNameCache ) import TyCon ( TyCon, tyConName ) -import Class ( Class ) import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) import Name ( Name, nameUnique, nameModule, @@ -29,11 +27,9 @@ import Name ( Name, nameUnique, nameModule, getOccName, nameParent_maybe, isWiredInName, mkIPName, mkExternalName, mkInternalName ) -import NameEnv import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name ) -import HscTypes ( ExternalPackageState, NameCache, TyThing(..) ) import Module ( Module, ModuleName, moduleName, mkPackageModule, emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 9163560a4c..6a0a1c79ba 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -40,9 +40,9 @@ import IfaceType import FunDeps ( pprFundeps ) import NewDemand ( StrictSig, pprIfaceStrictSig ) -import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred ) -import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy, - mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType ) +import TcType ( deNoteType, tcSplitDFunTy, mkClassPred ) +import Type ( TyThing(..), mkForAllTys, splitForAllTys, funResultTy, + mkPredTy, tidyTopType ) import InstEnv ( DFunId ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import NewDemand ( isTopSig ) @@ -50,12 +50,12 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), arityInfo, cafInfo, newStrictnessInfo, workerInfo, unfoldingInfo, inlinePragInfo ) import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, - isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, - tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, - tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) + tyConHasGenerics, tyConArgVrcs, getSynTyConDefn, + tyConArity, tyConTyVars, algTcRhs, tyConExtName ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, - dataConTyCon, dataConIsInfix ) + dataConTyCon, dataConIsInfix, isVanillaDataCon ) import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv, lookupOccEnv, extendOccEnv, emptyOccEnv, @@ -92,8 +92,7 @@ data IfaceDecl ifType :: IfaceType, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifCtxt :: IfaceContext, -- Context - ifName :: OccName, -- Type constructor + | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? @@ -109,16 +108,16 @@ data IfaceDecl ifSynRhs :: IfaceType -- synonym expansion } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep OccName], -- Functional dependencies - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType @@ -128,22 +127,30 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType data IfaceConDecls = IfAbstractTyCon -- No info - | IfDataTyCon [IfaceConDecl] -- data type decls + | IfDataTyCon -- data type decls + (Maybe IfaceContext) -- See TyCon.AlgTyConRhs; H98 or GADT + [IfaceConDecl] | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls IfAbstractTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon _ cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl - = IfaceConDecl OccName -- Constructor name - Bool -- True <=> declared infix - [IfaceTvBndr] -- Existental tyvars - IfaceContext -- Existential context - [IfaceType] -- Arg types - [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types - [OccName] -- ...ditto... (field labels) + = IfVanillaCon { + ifConOcc :: OccName, -- Constructor name + ifConInfix :: Bool, -- True <=> declared infix + ifConArgTys :: [IfaceType], -- Arg types + ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types + ifConFields :: [OccName] } -- ...ditto... (field labels) + | IfGadtCon { + ifConOcc :: OccName, -- Constructor name + ifConTyVars :: [IfaceTvBndr], -- All tyvars + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConResTys :: [IfaceType], -- Result type args + ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified -- so that it'll compare alpha-wise @@ -201,7 +208,8 @@ data IfaceExpr | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr OccName [IfaceAlt] +-- gaw 2004 + | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceLit Literal @@ -253,15 +261,18 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, i 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) -pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen, - ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) +pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifVrcs = vrcs}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls]) + 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) where - pp_nd = case condecls of - IfAbstractTyCon -> ptext SLIT("data") - IfDataTyCon _ -> ptext SLIT("data") - IfNewTyCon _ -> ptext SLIT("newtype") + (context, pp_nd) + = case condecls of + IfAbstractTyCon -> ([], ptext SLIT("data")) + IfDataTyCon Nothing _ -> ([], ptext SLIT("data")) + IfDataTyCon (Just c) _ -> (c, ptext SLIT("data")) + IfNewTyCon _ -> ([], ptext SLIT("newtype")) pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) @@ -282,20 +293,35 @@ pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] -pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}") -pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) -pp_condecls (IfNewTyCon c) = equals <+> ppr c +pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc (IfDataTyCon _ cs) = equals <+> sep (punctuate (ptext SLIT(" |")) + (map (pprIfaceConDecl tc) cs)) -instance Outputable IfaceConDecl where - ppr (IfaceConDecl name is_infix ex_tvs ex_ctxt arg_tys strs fields) - = pprIfaceForAllPart ex_tvs ex_ctxt $ - sep [ppr name <+> sep (map pprParendIfaceType arg_tys), +pprIfaceConDecl tc (IfVanillaCon { + ifConOcc = name, ifConInfix = is_infix, + ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) + = sep [ppr name <+> sep (map pprParendIfaceType arg_tys), if is_infix then ptext SLIT("Infix") else empty, if null strs then empty else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)), if null fields then empty else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))] +pprIfaceConDecl tc (IfGadtCon { + ifConOcc = name, + ifConTyVars = tvs, ifConCtxt = ctxt, + ifConArgTys = arg_tys, ifConResTys = res_tys, + ifConStricts = strs }) + = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau), + if null strs then empty + else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))] + where + con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) + tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys + -- Gruesome, but jsut for debug print + instance Outputable IfaceRule where ppr (IfaceRule name act bndrs fn args rhs) = sep [hsep [doubleQuotes (ftext name), ppr act, @@ -340,13 +366,17 @@ pprIfaceExpr add_par e@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) @@ -458,10 +488,9 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) ifSynRhs = toIfaceType ext syn_ty } | isAlgTyCon tycon - = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon), - ifName = getOccName tycon, + = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifCons = ifaceConDecls (algTyConRhs tycon), + ifCons = ifaceConDecls (algTcRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifVrcs = tyConArgVrcs tycon, ifGeneric = tyConHasGenerics tycon } @@ -472,8 +501,7 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) | isPrimTyCon tycon || isFunTyCon tycon -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifCtxt = [], - ifName = getOccName tycon, + = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), ifCons = IfAbstractTyCon, ifGeneric = False, @@ -488,7 +516,8 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) ifaceConDecls _ | abstract = IfAbstractTyCon ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls (DataTyCon mb_theta cons _) = IfDataTyCon (ifaceDataCtxt mb_theta) + (map ifaceConDecl cons) ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case should never happen when we are generating an -- interface file (we're exporting this thing, so it's locally defined @@ -496,16 +525,25 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) -- in TcRnDriver for GHCi, when browsing a module, in which case the -- AbstractTyCon case is perfectly sensible. + ifaceDataCtxt Nothing = Nothing + ifaceDataCtxt (Just theta) = Just (toIfaceContext ext theta) + ifaceConDecl data_con - = IfaceConDecl (getOccName (dataConName data_con)) - (dataConIsInfix data_con) - (toIfaceTvBndrs ex_tyvars) - (toIfaceContext ext ex_theta) - (map (toIfaceType ext) arg_tys) - strict_marks - (map getOccName field_labels) + | isVanillaDataCon data_con + = IfVanillaCon {ifConOcc = getOccName (dataConName data_con), + ifConInfix = dataConIsInfix data_con, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConStricts = strict_marks, + ifConFields = map getOccName field_labels } + | otherwise + = IfGadtCon { ifConOcc = getOccName (dataConName data_con), + ifConTyVars = toIfaceTvBndrs tyvars, + ifConCtxt = toIfaceContext ext theta, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConResTys = map (toIfaceType ext) res_tys, + ifConStricts = strict_marks } where - (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con + (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con @@ -602,7 +640,8 @@ toIfaceExpr ext (Lit l) = IfaceLit l toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) toIfaceExpr ext (App f a) = toIfaceApp ext f [a] -toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as) +-- gaw 2004 +toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) @@ -733,9 +772,11 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) ifVrcs d1 == ifVrcs d2 && ifGeneric d1 == ifGeneric d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& - eq_hsCD env (ifCons d1) (ifCons d2) + eq_hsCD env (ifCons d1) (ifCons d2) ) + -- The type variables of the data type do not scope + -- over the constructors (any more), but they do scope + -- over the stupid context in the IfaceConDecls eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& @@ -774,17 +815,30 @@ eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1) eq_ifaceExpr env rhs1 rhs2) eqIfRule _ _ = NotEqual -eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2 +eq_hsCD env (IfDataTyCon st1 c1) (IfDataTyCon st2 c2) + = eqMaybeBy (eq_ifContext env) st1 st2 &&& + eqListBy (eq_ConDecl env) c1 c2 + eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal eq_hsCD env d1 d2 = NotEqual -eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1) - (IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2) - = bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&& - eq_ifTvBndrs env tvs1 tvs2 (\ env -> - eq_ifContext env cxt1 cxt2 &&& - eq_ifTypes env args1 args2) +eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConInfix c1 == ifConInfix c2 && + ifConStricts c1 == ifConStricts c2 && + ifConFields c1 == ifConFields c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2) + +eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConStricts c1 == ifConStricts c2) &&& + eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env -> + eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&& + eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)) + +eq_ConDecl env c1 c2 = NotEqual eq_hsFD env (ns1,ms1) (ns2,ms2) = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 @@ -819,8 +873,9 @@ eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2 -eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2) +eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) = eq_ifaceExpr env s1 s2 &&& + eq_ifType env ty1 ty2 &&& eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2) where eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2) diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index e5d91dea13..b771e5a403 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -30,7 +30,7 @@ import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) import Var ( isId, tyVarKind, idType ) import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) import OccName ( OccName ) -import Name ( Name, getName, getOccName, nameModuleName, nameOccName, isInternalName ) +import Name ( Name, getName, getOccName, nameModuleName, nameOccName ) import Module ( ModuleName ) import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) import Outputable diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index d2a0f48907..62e31d4605 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -22,15 +22,14 @@ import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas opt_InPackage ) import Parser ( parseIface ) -import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClassOp(..), +import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName ) + IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc ) -import HscTypes ( HscEnv(..), ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, +import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, lookupIfaceByModName, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, mkTypeEnv, - Gated, implicitTyThings, + IsBootInterface, mkIfaceFixCache, Gated, implicitTyThings, addRulesToPool, addInstsToPool ) @@ -40,7 +39,7 @@ import Type ( funTyCon ) import TcRnMonad import PrelNames ( gHC_PRIM_Name ) -import PrelInfo ( ghcPrimExports, wiredInThings ) +import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) import Rules ( emptyRuleBase ) import InstEnv ( emptyInstEnv ) @@ -50,7 +49,7 @@ import NameEnv import MkId ( seqId ) import Packages ( basePackage ) import Module ( Module, ModuleName, ModLocation(ml_hi_file), - moduleName, isHomeModule, emptyModuleEnv, moduleEnvElts, + moduleName, isHomeModule, emptyModuleEnv, extendModuleEnv, lookupModuleEnvByName, moduleUserString ) import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, @@ -330,26 +329,30 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon}) = [] -ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfaceConDecl con_occ _ _ _ _ _ fields)}) +-- Newtype +ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ, + ifConFields = fields})}) = fields ++ [con_occ, mkDataConWrapperOcc con_occ] -- Wrapper, no worker; see MkId.mkDataConIds -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) +ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) = nub (concatMap fld_occs cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons where - fld_occs (IfaceConDecl _ _ _ _ _ _ fields) = fields - dc_occs (IfaceConDecl con_occ _ _ _ _ strs _) + fld_occs (IfVanillaCon { ifConFields = fields }) = fields + fld_occs (IfGadtCon {}) = [] + dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] | otherwise = [con_occ, work_occ] where + con_occ = ifConOcc con_decl + strs = ifConStricts con_decl wrap_occ = mkDataConWrapperOcc con_occ work_occ = mkDataConWorkerOcc con_occ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) -- ToDo: may miss strictness in existential dicts -ifaceDeclSubBndrs _other = [] - +ifaceDeclSubBndrs _other = [] ----------------------------------------------------- -- Loading instance decls diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index c7a71b7098..e8fbeb0fd4 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -191,7 +191,7 @@ import HscTypes ( ModIface(..), TyThing(..), Dependencies(..), FixItem(..), mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, - Avails, AvailInfo, GenAvailInfo(..), availName, + GenAvailInfo(..), availName, ExternalPackageState(..), Usage(..), IsBootInterface, Deprecs(..), IfaceDeprecs, Deprecations, @@ -209,10 +209,9 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOc extendOccSet, extendOccSetList, isEmptyOccSet, intersectOccSet, intersectsOccSet, occNameFS, isTcOcc ) -import TyCon ( visibleDataCons, tyConDataCons, isNewTyCon, newTyConRep ) +import TyCon ( tyConDataCons, isNewTyCon, newTyConRep ) import Class ( classSelIds ) import DataCon ( dataConName, dataConFieldLabels ) -import FieldLabel ( fieldLabelName ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, @@ -358,9 +357,7 @@ mustExposeThing exports (ATyCon tc) -- can only do that if it can "see" the newtype representation where exported_data_con con - = any (`elemNameSet` exports) (dataConName con : field_names) - where - field_names = map fieldLabelName (dataConFieldLabels con) + = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) mustExposeThing exports (AClass cls) = any exported_class_op (classSelIds cls) @@ -535,7 +532,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, eq_ind_occs [op | IfaceClassOp op _ _ <- sigs] eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons}) = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too - eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ _ <- visibleIfConDecls cons] + eq_ind_occs (map ifConOcc (visibleIfConDecls cons)) eq_indirects other = Equal -- Synonyms and foreign declarations eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules @@ -766,7 +763,6 @@ mkIfaceExports exports (unitFM avail_fs avail) where occ = nameOccName name - occ_fs = occNameFS occ mod_fs = moduleNameFS (nameModuleName name) avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] | isTcOcc occ = AvailTC occ [occ] diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 1d08095f26..2ca88bad3b 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -26,10 +26,9 @@ import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), InstPool, ModGuts, - TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList, - lookupTypeEnv, lookupType, typeEnvIds, - RulePool ) + ModIface(..), ModDetails(..), ModGuts, + mkTypeEnv, extendTypeEnv, + lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( extendInstEnv ) import CoreSyn import PprCore ( pprIdRules ) @@ -46,13 +45,12 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), setArityInfo, setInlinePragInfo, setCafInfo, vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) -import TyCon ( tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) -import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon, - tupleTyCon, tupleCon ) +import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) +import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon ) +import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom, - isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe ) +import Name ( Name, nameModuleName, nameModule, nameIsLocalOrFrom, + isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) import Module ( Module, ModuleName, moduleName ) @@ -60,11 +58,7 @@ import UniqSupply ( initUs_ ) import Outputable import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, dropList, equalLength, zipLazy ) -import Maybes ( expectJust ) import CmdLineOpts ( DynFlag(..) ) - -import UniqFM (sizeUFM) - \end{code} This module takes @@ -262,35 +256,22 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) ; return (AnId (mkVanillaGlobal name ty info)) } tcIfaceDecl (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, + ifTyVars = tv_bndrs, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, ifGeneric = want_generic }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do - { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt) - - ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $ - tcIfaceCtxt rdr_ctxt - -- The reason for laziness here is to postpone - -- looking at the context, because the class may not - -- be in the type envt yet. E.g. - -- class Real a where { toRat :: a -> Ratio Integer } - -- data (Real a) => Ratio a = ... - -- We suck in the decl for Real, and type check it, which sucks - -- in the data type Ratio; but we must postpone typechecking the - -- context - - ; tycon <- fixM ( \ tycon -> do - { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons - ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons + { tycon <- fixM ( \ tycon -> do + { cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; tycon <- buildAlgTyCon tc_name tyvars cons arg_vrcs is_rec want_generic ; return tycon }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) - } } + }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) @@ -330,30 +311,58 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0 [])) } -tcIfaceDataCons tycon tyvars ctxt if_cons +tcIfaceDataCons tycon tc_tyvars if_cons = case if_cons of - IfAbstractTyCon -> return mkAbstractTyConRhs - IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs data_con) } + IfAbstractTyCon -> return mkAbstractTyConRhs + IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt + ; data_cons <- mappM tc_con_decl cons + ; return (mkDataTyConRhs mb_theta data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; return (mkNewTyConRhs tycon data_con) } where - tc_con_decl (IfaceConDecl occ is_infix ex_tvs ex_ctxt args stricts field_lbls) - = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do - { name <- lookupIfaceTop occ - ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here + tc_ctxt Nothing = return Nothing + tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) } + + tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, + ifConStricts = stricts, ifConFields = field_lbls}) + = do { name <- lookupIfaceTop occ + -- Read the argument types, but lazily to avoid faulting in + -- the component types unless they are really needed + ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) + ; lbl_names <- mappM lookupIfaceTop field_lbls + ; buildDataCon name is_infix True {- Vanilla -} + stricts lbl_names + tc_tyvars [] arg_tys tycon + (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys + } + + tc_con_decl (IfGadtCon { ifConTyVars = con_tvs, + ifConOcc = occ, ifConCtxt = ctxt, + ifConArgTys = args, ifConResTys = ress, + ifConStricts = stricts}) + = bindIfaceTyVars con_tvs $ \ con_tyvars -> do + { name <- lookupIfaceTop occ + ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here + -- At one stage I thought that this context checking *had* + -- to be lazy, because of possible mutual recursion between the + -- type and the classe: + -- E.g. + -- class Real a where { toRat :: a -> Ratio Integer } + -- data (Real a) => Ratio a = ... + -- But now I think that the laziness in checking class ops breaks + -- the loop, so no laziness needed -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ; - - ; lbl_names <- mappM lookupIfaceTop field_lbls + ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) + ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) - ; buildDataCon name is_infix stricts lbl_names - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon + ; buildDataCon name False {- Not infix -} False {- Not vanilla -} + stricts [{- No fields -}] + con_tyvars theta + arg_tys tycon res_tys } - mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args] + mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name \end{code} @@ -626,7 +635,8 @@ tcIfaceExpr (IfaceApp fun arg) tcIfaceExpr arg `thenM` \ arg' -> returnM (App fun' arg') -tcIfaceExpr (IfaceCase scrut case_bndr alts) +-- gaw 2004 +tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = tcIfaceExpr scrut `thenM` \ scrut' -> newIfaceName case_bndr `thenM` \ case_bndr_name -> let @@ -641,7 +651,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) in extendIfaceIdEnv [case_bndr'] $ mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - returnM (Case scrut' case_bndr' alts') + tcIfaceType ty `thenM` \ ty' -> + returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = tcIfaceExpr rhs `thenM` \ rhs' -> @@ -683,45 +694,42 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) - = let - tycon_mod = nameModuleName (tyConName tycon) - in - tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con -> - newIfaceNames arg_occs `thenM` \ arg_names -> - let - ex_tyvars = dataConExistentialTyVars con - main_tyvars = tyConTyVars tycon - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = dropList ex_tyvars arg_names - arg_ids -#ifdef DEBUG - | not (equalLength id_names arg_tys) - = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$ - (ppr main_tyvars <+> ppr ex_tyvars) $$ - ppr arg_tys) - | otherwise -#endif - = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys - in - ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars ) - extendIfaceTyVarEnv ex_tyvars' $ - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + = do { let tycon_mod = nameModuleName (tyConName tycon) + ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) + ; ASSERT2( con `elem` tyConDataCons tycon, + ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) + + if isVanillaDataCon con then + tcVanillaAlt con inst_tys arg_occs rhs + else + do { -- General case + arg_names <- newIfaceNames arg_occs + ; let tyvars = [ mkTyVar name (tyVarKind tv) + | (name,tv) <- arg_names `zip` dataConTyVars con] + arg_tys = dataConArgTys con (mkTyVarTys tyvars) + id_names = dropList tyvars arg_names + arg_ids = ASSERT2( equalLength id_names arg_tys, + ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) + zipWith mkLocalId id_names arg_tys + + ; rhs' <- extendIfaceTyVarEnv tyvars $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) - = newIfaceNames arg_occs `thenM` \ arg_names -> - let - [con] = tyConDataCons tycon - arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys - in - ASSERT( isTupleTyCon tycon ) - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, arg_ids, rhs') + = ASSERT( isTupleTyCon tycon ) + do { let [data_con] = tyConDataCons tycon + ; tcVanillaAlt data_con inst_tys arg_occs rhs } + +tcVanillaAlt data_con inst_tys arg_occs rhs + = do { arg_names <- newIfaceNames arg_occs + ; let arg_tys = dataConArgTys data_con inst_tys + ; let arg_ids = ASSERT2( equalLength arg_names arg_tys, + ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs ) + zipWith mkLocalId arg_names arg_tys + ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) + ; returnM (DataAlt data_con, arg_ids, rhs') } \end{code} |