diff options
122 files changed, 4269 insertions, 3968 deletions
diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index 3e67308be1..8f63938dcc 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -32,14 +32,14 @@ then then CoreSyn then - IdInfo (loop CoreSyn.CoreRules etc, loop CoreUnfold.Unfolding) + IdInfo (CoreSyn.Unfolding, CoreSyn.CoreRules) then Id (lots from IdInfo) then CoreFVs, PprCore then CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars, - loop CoreUnfold.isEvaldUnfolding CoreUnfold.maybeUnfoldingTemplate) + CoreSyn.isEvaldUnfolding CoreSyn.maybeUnfoldingTemplate) then OccurAnal (CoreUtils.exprIsTrivial) then diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 5ddc45204a..14c9893bef 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -14,7 +14,7 @@ types that \begin{code} module BasicTypes( - Version, + Version, bumpVersion, initialVersion, bogusVersion, Arity, @@ -29,7 +29,10 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, + Boxity(..), isBoxed, tupleParens, + OccInfo(..), seqOccInfo, isFragileOccInfo, isLoopBreaker, + InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch @@ -75,6 +78,15 @@ type Arity = Int \begin{code} type Version = Int + +bogusVersion :: Version -- Shouldn't look at these +bogusVersion = error "bogusVersion" + +bumpVersion :: Version -> Version +bumpVersion v = v+1 + +initialVersion :: Version +initialVersion = 1 \end{code} @@ -146,6 +158,28 @@ isTopLevel NotTopLevel = False %************************************************************************ %* * +\subsection[Top-level/local]{Top-level/not-top level flag} +%* * +%************************************************************************ + +\begin{code} +data Boxity + = Boxed + | Unboxed + deriving( Eq ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +tupleParens :: Boxity -> SDoc -> SDoc +tupleParens Boxed p = parens p +tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") +\end{code} + + +%************************************************************************ +%* * \subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index a9aac4c7ed..be1cf56ac9 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -32,9 +32,9 @@ import TysPrim import Type ( Type, ThetaType, TauType, ClassContext, mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTys, mkDictTys, - splitAlgTyConApp_maybe, classesToPreds + splitTyConApp_maybe, classesToPreds ) -import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, +import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( classTyCon ) import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) @@ -120,7 +120,7 @@ data DataCon dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, -- and including existential dictionaries - dcTyCon :: TyCon, -- Result tycon + dcTyCon :: TyCon, -- Result tycon -- Now the strictness annotations and field labels of the constructor dcUserStricts :: [StrictnessMark], @@ -404,6 +404,7 @@ splitProductType_maybe [Type]) -- Its *representation* arg types -- Returns (Just ...) for any + -- concrete (i.e. constructors visible) -- single-constructor -- not existentially quantified -- type whether a data type or a new type @@ -413,10 +414,13 @@ splitProductType_maybe -- it through till someone finds it's important. splitProductType_maybe ty - = case splitAlgTyConApp_maybe ty of - Just (tycon,ty_args,[data_con]) - | isProductTyCon tycon -- Includes check for non-existential + = case splitTyConApp_maybe ty of + Just (tycon,ty_args) + | isProductTyCon tycon -- Includes check for non-existential, + -- and for constructors visible -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args) + where + data_con = head (tyConDataConsIfAvailable tycon) other -> Nothing splitProductType str ty diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 7f376fd326..546e3a2bbb 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -66,7 +66,8 @@ type MaybeAbsent = Bool -- True <=> not even used wwLazy = WwLazy False wwStrict = WwStrict wwUnpackData xs = WwUnpack DataType False xs -wwUnpackNew x = WwUnpack NewType False [x] +wwUnpackNew x = ASSERT( isStrict x) -- Invariant + WwUnpack NewType False [x] wwPrim = WwPrim wwEnum = WwEnum @@ -87,25 +88,20 @@ seqDemands (d:ds) = seqDemand d `seq` seqDemands ds %************************************************************************ \begin{code} +isLazy :: Demand -> Bool + -- Even a demand of (WwUnpack NewType _ _) is strict + -- We don't create such a thing unless the demand inside is strict +isLazy (WwLazy _) = True +isLazy _ = False + isStrict :: Demand -> Bool -isStrict (WwUnpack NewType _ ds) = isStrict (head ds) -isStrict (WwUnpack other _ _) = True -isStrict WwStrict = True -isStrict WwEnum = True -isStrict WwPrim = True -isStrict _ = False +isStrict d = not (isLazy d) isPrim :: Demand -> Bool isPrim WwPrim = True isPrim other = False \end{code} -\begin{code} -isLazy :: Demand -> Bool -isLazy (WwLazy False) = True -- NB "Absent" args do *not* count! -isLazy _ = False -- (as they imply a worker) -\end{code} - %************************************************************************ %* * @@ -174,6 +170,7 @@ data StrictnessInfo -- BUT NB: f = \x y. error "urk" -- will have info SI [SS] True -- but still (f) and (f 2) are not bot; only (f 3 2) is bot + deriving( Eq ) -- NOTA BENE: if the arg demands are, say, [S,L], this means that -- (f bot) is not necy bot, only (f bot x) is bot @@ -191,8 +188,11 @@ seqStrictnessInfo other = () mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo mkStrictnessInfo (xs, is_bot) - | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs is_bot + | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting + | otherwise = StrictnessInfo xs is_bot + where + totally_boring (WwLazy False) = True + totally_boring other = False noStrictnessInfo = NoStrictnessInfo @@ -203,8 +203,7 @@ isBottomingStrictness NoStrictnessInfo = False appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds) appIsBottom NoStrictnessInfo n = False -ppStrictnessInfo NoStrictnessInfo = empty -ppStrictnessInfo (StrictnessInfo wrapper_args bot) - = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot] +ppStrictnessInfo NoStrictnessInfo = empty +ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot] \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 26bd7991f6..0076c36bf8 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -95,7 +95,7 @@ import OccName ( UserFS ) import PrimRep ( PrimRep ) import PrimOp ( PrimOp, primOpIsCheap ) import TysPrim ( statePrimTyCon ) -import FieldLabel ( FieldLabel(..) ) +import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) import Outputable diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 502a904913..8cc168dd0a 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -290,6 +290,7 @@ data ArityInfo -- functions in the module being compiled. Their arity -- might increase later in the compilation process, if -- an extra lambda floats up to the binding site. + deriving( Eq ) seqArity :: ArityInfo -> () seqArity a = arityLowerBound a `seq` () @@ -323,6 +324,7 @@ data InlinePragInfo = NoInlinePragInfo | IMustNotBeINLINEd Bool -- True <=> came from an INLINE prag, False <=> came from a NOINLINE prag (Maybe Int) -- Phase number from pragma, if any + deriving( Eq ) -- The True, Nothing case doesn't need to be recorded -- SEE COMMENTS WITH CoreUnfold.blackListed on the diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 5356710097..ca14f9a969 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -8,7 +8,7 @@ module Literal ( Literal(..) -- Exported to ParseIface , mkMachInt, mkMachWord , mkMachInt64, mkMachWord64 - , isLitLitLit + , isLitLitLit, maybeLitLit , literalType, literalPrimRep , hashLiteral @@ -38,10 +38,6 @@ import Util ( thenCmp ) import Ratio ( numerator, denominator ) import FastString ( uniqueOfFS ) import Char ( ord, chr ) - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif \end{code} @@ -179,6 +175,9 @@ double2FloatLit (MachDouble d) = MachFloat d \begin{code} isLitLitLit (MachLitLit _ _) = True isLitLitLit _ = False + +maybeLitLit (MachLitLit s t) = Just (s,t) +maybeLitLit _ = Nothing \end{code} Types diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 3206e03f28..9c52fdd38e 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -37,7 +37,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, intPrimTy, realWorldStatePrimTy ) import TysWiredIn ( boolTy, charTy, mkListTy ) -import PrelMods ( pREL_ERR, pREL_GHC ) +import PrelNames ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, @@ -51,6 +51,7 @@ import PprType ( pprParendType ) import Module ( Module ) import CoreUtils ( exprType, mkInlineMe ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) +import Literal ( Literal(..) ) import Subst ( mkTopTyVarSubst, substClasses ) import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, tyConTheta, isProductTyCon, isUnboxedTupleTyCon ) @@ -66,7 +67,7 @@ import PrimOp ( PrimOp(DataToTagOp, CCallOp), primOpSig, mkPrimOpIdName, CCall, pprCCallOp ) -import Demand ( wwStrict, wwPrim ) +import Demand ( wwStrict, wwPrim, mkStrictnessInfo ) import DataCon ( DataCon, StrictnessMark(..), dataConFieldLabels, dataConRepArity, dataConTyCon, dataConArgTys, dataConRepType, dataConRepStrictness, @@ -168,7 +169,7 @@ mkDataConId work_name data_con arity = dataConRepArity data_con - strict_info = StrictnessInfo (dataConRepStrictness data_con) False + strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False) cpr_info | isProductTyCon tycon && not (isUnboxedTupleTyCon tycon) && @@ -373,9 +374,11 @@ Similarly for newtypes unN = /\a -> \n:N -> coerce (a->a) n \begin{code} -mkRecordSelId tycon field_label - -- Assumes that all fields with the same field label - -- have the same type +mkRecordSelId tycon field_label unpack_id + -- Assumes that all fields with the same field label have the same type + -- + -- Annoyingly, we have to pass in the unpackCString# Id, because + -- we can't conjure it up out of thin air = sel_id where sel_id = mkId (fieldLabelName field_label) selector_ty info @@ -441,8 +444,9 @@ mkRecordSelId tycon field_label field_lbls = dataConFieldLabels data_con maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label - error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), mkStringLit full_msg] + error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string] -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04. + err_string = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg))) full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) \end{code} @@ -459,6 +463,7 @@ there's nothing to do. ToDo: unify with mkRecordSelId. \begin{code} +mkDictSelId :: Name -> Class -> Id mkDictSelId name clas = sel_id where diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 2650e2e537..92877df6e8 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -5,6 +5,19 @@ Representing modules and their flavours. + +Notes on DLLs +~~~~~~~~~~~~~ +When compiling module A, which imports module B, we need to +know whether B will be in the same DLL as A. + If it's in the same DLL, we refer to B_f_closure + If it isn't, we refer to _imp__B_f_closure +When compiling A, we record in B's Module value whether it's +in a different DLL, by setting the DLL flag. + + + + \begin{code} module Module ( @@ -93,27 +106,6 @@ instance Show PackageInfo where -- Just used in debug prints of lex tokens %************************************************************************ %* * -\subsection{System/user module} -%* * -%************************************************************************ - -We also track whether an imported module is from a 'system-ish' place. In this case -we don't record the fact that this module depends on it, nor usages of things -inside it. - -Apr 00: We want to record dependencies on all modules other than -prelude modules else STG Hugs gets confused because it uses this -info to know what modules to link. (Compiled GHC uses command line -options to specify this.) - -\begin{code} -data ModFlavour = PrelMod -- A Prelude module - | UserMod -- Not library-ish -\end{code} - - -%************************************************************************ -%* * \subsection{Where from} %* * %************************************************************************ @@ -201,6 +193,7 @@ mkModule mod_nm pack_name pack_info | pack_name == opt_InPackage = ThisPackage | otherwise = AnotherPackage pack_name + mkVanillaModule :: ModuleName -> Module mkVanillaModule name = Module name ThisPackage -- Used temporarily when we first come across Foo.x in an interface diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 83508b525a..ff8096a929 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -21,7 +21,7 @@ module Name ( nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason, tidyTopName, - nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, toRdrName, isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, maybeUserImportedFrom, @@ -29,6 +29,13 @@ module Name ( isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + -- Environment + NameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + addToNameEnv_C, addToNameEnv, addListToNameEnv, + plusNameEnv, plusNameEnv_C, extendNameEnv, + lookupNameEnv, delFromNameEnv, elemNameEnv, + -- Provenance Provenance(..), ImportReason(..), pprProvenance, @@ -51,7 +58,8 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) -import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i ) +import Unique ( pprUnique, Unique, Uniquable(..), hasKey, unboundKey, u2i ) +import UniqFM import Outputable import GlaExts \end{code} @@ -179,7 +187,7 @@ mkUnboundName :: RdrName -> Name mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey +isUnboundName name = name `hasKey` unboundKey \end{code} \begin{code} @@ -420,6 +428,8 @@ nameSortModule (WiredInId mod _) = mod nameSortModule (WiredInTyCon mod _) = mod nameRdrName :: Name -> RdrName +-- Makes a qualified name for top-level (Global) names, whether locally defined or not +-- and an unqualified name just for Locals nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ @@ -486,13 +496,16 @@ isGlobalName other = True isExternallyVisibleName name = isGlobalName name hasBetterProv :: Name -> Name -> Bool -hasBetterProv name1 name2 - = case n_prov name1 of - LocalDef _ _ -> True - SystemProv -> False - NonLocalDef _ _ -> case n_prov name2 of - LocalDef _ _ -> False - other -> True +-- Choose +-- a local thing over an imported thing +-- a user-imported thing over a non-user-imported thing +-- an explicitly-imported thing over an implicitly imported thing +hasBetterProv n1 n2 + = case (n_prov n1, n_prov n2) of + (LocalDef _ _, _ ) -> True + (NonLocalDef (UserImport _ _ True) _, _ ) -> True + (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True + other -> False isSystemName (Name {n_prov = SystemProv}) = True isSystemName other = False @@ -531,6 +544,43 @@ instance NamedThing Name where %************************************************************************ %* * +\subsection{Name environment} +%* * +%************************************************************************ + +\begin{code} +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +nameEnvElts :: NameEnv a -> [a] +addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a +addListToNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a + +emptyNameEnv = emptyUFM +nameEnvElts = eltsUFM +addToNameEnv_C = addToUFM_C +addToNameEnv = addToUFM +addListToNameEnv = addListToUFM +plusNameEnv = plusUFM +plusNameEnv_C = plusUFM_C +extendNameEnv = addListToUFM +lookupNameEnv = lookupUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM +unitNameEnv = unitUFM +\end{code} + + +%************************************************************************ +%* * \subsection{Pretty printing} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index d52773be47..98eb7c17dd 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -69,7 +69,14 @@ pprEncodedFS :: EncodedFS -> SDoc pprEncodedFS fs = getPprStyle $ \ sty -> if userStyle sty then - text (decode (_UNPK_ fs)) + let + s = decode (_UNPK_ fs) + c = head s + in + if startsVarSym c || startsConSym c then + parens (text s) + else + text s else ptext fs \end{code} @@ -614,32 +621,29 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs isLexConId cs -- Prefix type or data constructors | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)" | cs == SLIT("[]") = True - | c == '(' = True -- (), (,), (,,), ... - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs + | otherwise = startsConId (_HEAD_ cs) isLexVarId cs -- Ordinary prefix identifiers | _NULL_ cs = False -- e.g. "x", "_x" - | otherwise = isLower c || isLowerISO c || c == '_' - where - c = _HEAD_ cs + | otherwise = startsVarId (_HEAD_ cs) isLexConSym cs -- Infix type or data constructors | _NULL_ cs = False -- e.g. ":-:", ":", "->" - | otherwise = c == ':' - || cs == SLIT("->") - where - c = _HEAD_ cs + | cs == SLIT("->") = True + | otherwise = startsConSym (_HEAD_ cs) isLexVarSym cs -- Infix identifiers | _NULL_ cs = False -- e.g. "+" - | otherwise = isSymbolASCII c - || isSymbolISO c - where - c = _HEAD_ cs + | otherwise = startsVarSym (_HEAD_ cs) ------------- +startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool +startsVarSym c = isSymbolASCII c || isSymbolISO c -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors +startsVarId c = isLower c || isLowerISO c || c == '_' -- Ordinary Ids +startsConId c = isUpper c || isUpperISO c || c == '(' -- Ordinary type constructors and data constructors + + isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 0db2b48901..8686f708b4 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -17,7 +17,15 @@ module RdrName ( -- Destruction rdrNameModule, rdrNameOcc, setRdrNameOcc, - isRdrDataCon, isRdrTyVar, isQual, isUnqual + isRdrDataCon, isRdrTyVar, isQual, isUnqual, + + -- Environment + RdrNameEnv, + emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, + extendRdrEnv, rdrEnvToList, + + -- Printing; instance Outputable RdrName + pprUnqualRdrName ) where #include "HsVersions.h" @@ -31,6 +39,7 @@ import OccName ( NameSpace, tcName, import Module ( ModuleName, pprModuleName, mkSysModuleFS, mkSrcModuleFS ) +import FiniteMap import Outputable import Util ( thenCmp ) \end{code} @@ -134,8 +143,10 @@ isQual rdr_name = not (isUnqual rdr_name) instance Outputable RdrName where ppr (RdrName qual occ) = pp_qual qual <> ppr occ where - pp_qual Unqual = empty - pp_qual (Qual mod) = pprModuleName mod <> dot + pp_qual Unqual = empty + pp_qual (Qual mod) = pprModuleName mod <> dot + +pprUnqualRdrName (RdrName qual occ) = ppr occ instance Eq RdrName where a == b = case (a `compare` b) of { EQ -> True; _ -> False } @@ -159,3 +170,26 @@ cmpQual (Qual m1) (Qual m2) = m1 `compare` m2 +%************************************************************************ +%* * +\subsection{Environment} +%* * +%************************************************************************ + +\begin{code} +type RdrNameEnv a = FiniteMap RdrName a + +emptyRdrEnv :: RdrNameEnv a +lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a +addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a +extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a +rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] +rdrEnvElts :: RdrNameEnv a -> [a] + +emptyRdrEnv = emptyFM +lookupRdrEnv = lookupFM +addListToRdrEnv = addListToFM +rdrEnvElts = eltsFM +extendRdrEnv = addToFM +rdrEnvToList = fmToList +\end{code} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index a04fbd6f69..8850936eb3 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -16,7 +16,7 @@ Haskell). \begin{code} module Unique ( - Unique, Uniquable(..), + Unique, Uniquable(..), hasKey, u2i, -- hack: used in UniqFM pprUnique, pprUnique10, @@ -30,16 +30,14 @@ module Unique ( initTyVarUnique, initTidyUniques, - isTupleKey, + isTupleKey, -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] mkAlphaTyVarUnique, mkPrimOpIdUnique, mkTupleDataConUnique, - mkUbxTupleDataConUnique, mkTupleTyConUnique, - mkUbxTupleTyConUnique, getBuiltinUniques, mkBuiltinUnique, mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, @@ -198,6 +196,7 @@ module Unique ( #include "HsVersions.h" +import BasicTypes ( Boxity(..) ) import FastString ( FastString, uniqueOfFS ) import GlaExts import ST @@ -290,6 +289,9 @@ unpkUnique (MkUnique u) class Uniquable a where getUnique :: a -> Unique +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + instance Uniquable FastString where getUnique fs = mkUniqueGrimily (uniqueOfFS fs) @@ -430,8 +432,8 @@ mkAlphaTyVarUnique i = mkUnique '1' i mkPreludeClassUnique i = mkUnique '2' i mkPreludeTyConUnique i = mkUnique '3' i -mkTupleTyConUnique a = mkUnique '4' a -mkUbxTupleTyConUnique a = mkUnique '5' a +mkTupleTyConUnique Boxed a = mkUnique '4' a +mkTupleTyConUnique Unboxed a = mkUnique '5' a -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that @@ -440,8 +442,8 @@ mkUbxTupleTyConUnique a = mkUnique '5' a -- representation). mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic -mkTupleDataConUnique a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkUbxTupleDataConUnique a = mkUnique '8' (2*a) +mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) -- This one is used for a tiresome reason -- to improve a consistency-checking error check in the renamer diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b9c3149194..d64755b4b8 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.41 2000/04/13 20:41:30 panne Exp $ +% $Id: CgCase.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $ % %******************************************************** %* * @@ -59,7 +59,7 @@ import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon, - tyConDataCons, tyConFamilySize ) + ) import Type ( Type, typePrimRep, splitAlgTyConApp, splitTyConApp_maybe, repType ) import PprType ( {- instance Outputable Type -} ) diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index f02b4d6590..e292ea1d9f 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP Project, Glasgow University, 1992-1998 % -% $Id: CgRetConv.lhs,v 1.21 2000/04/05 16:25:51 simonpj Exp $ +% $Id: CgRetConv.lhs,v 1.22 2000/05/25 12:41:15 simonpj Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -30,7 +30,7 @@ import Maybes ( catMaybes ) import DataCon ( DataCon ) import PrimOp ( PrimOp{-instance Outputable-} ) import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) -import TyCon ( TyCon, tyConDataCons, tyConFamilySize ) +import TyCon ( TyCon, tyConFamilySize ) import Type ( Type, typePrimRep, isUnLiftedType ) import Util ( isn'tIn ) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index d107e7eb61..302dbc4438 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.41 2000/04/05 15:17:38 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -81,8 +81,9 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_SMP ) import Id ( Id, idType, idArityInfo ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isNullaryDataCon, isTupleCon, dataConName + isNullaryDataCon, dataConName ) +import TyCon ( isBoxedTupleTyCon ) import IdInfo ( ArityInfo(..) ) import Name ( Name, isExternallyVisibleName, nameUnique, getOccName ) @@ -238,7 +239,8 @@ mkConLFInfo :: DataCon -> LambdaFormInfo mkConLFInfo con = -- the isNullaryDataCon will do this: ASSERT(isDataCon con) - (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con) + (if isBoxedTupleTyCon (dataConTyCon con) then LFTuple else LFCon) + con (isNullaryDataCon con) mkSelectorLFInfo rhs_ty offset updatable = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset) diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 3c4d5c87c9..57844395ca 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -7,7 +7,10 @@ Taken quite directly from the Peyton Jones/Lester paper. module CoreFVs ( exprFreeVars, exprsFreeVars, exprSomeFreeVars, exprsSomeFreeVars, - idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars, + idRuleVars, idFreeVars, + ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars, + + mustHaveLocalBinding, CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf, ) where @@ -15,14 +18,30 @@ module CoreFVs ( #include "HsVersions.h" import CoreSyn -import Id ( Id, idFreeTyVars, idSpecialisation ) +import Id ( Id, idFreeTyVars, mayHaveNoBinding, idSpecialisation ) import VarSet import Var ( Var, isId ) import Name ( isLocallyDefined ) import Type ( tyVarsOfType, Type ) import Util ( mapAndUnzip ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\section{Utilities} +%* * +%************************************************************************ + +\begin{code} +mustHaveLocalBinding :: Var -> Bool +-- True <=> the variable must have a binding in this module +mustHaveLocalBinding v + | isId v = isLocallyDefined v && not (mayHaveNoBinding v) + | otherwise = True -- TyVars etc must \end{code} + %************************************************************************ %* * \section{Finding the free variables of an expression} @@ -75,9 +94,10 @@ noVars fv_cand in_scope = emptyVarSet -- is a little weird. The reason is that the former is more efficient, -- but the latter is more fine grained, and a makes a difference when -- a variable mentions itself one of its own rule RHSs -oneVar :: Var -> FV +oneVar :: Id -> FV oneVar var fv_cand in_scope - = foldVarSet add_rule_var var_itself_set (idRuleVars var) + = ASSERT( isId var ) + foldVarSet add_rule_var var_itself_set (idRuleVars var) where var_itself_set | keep_it fv_cand in_scope var = unitVarSet var | otherwise = emptyVarSet @@ -134,15 +154,22 @@ expr_fvs (Let (Rec pairs) body) \begin{code} idRuleVars ::Id -> VarSet -idRuleVars id = rulesRhsFreeVars (idSpecialisation id) +idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) idFreeVars :: Id -> VarSet -idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id +idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet rulesSomeFreeVars interesting (Rules rules _) = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule _) = noFVs +ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) + = rule_fvs isLocallyDefined emptyVarSet + where + rule_fvs = addBndrs tpl_vars (expr_fvs rhs) + ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet ruleSomeFreeVars interesting (BuiltinRule _) = noFVs ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 3dc98933d2..9b45e65dad 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -16,13 +16,13 @@ import IO ( hPutStr, hPutStrLn, stderr, stdout ) import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) import CoreSyn -import CoreFVs ( idFreeVars ) +import CoreFVs ( idFreeVars, mustHaveLocalBinding ) import CoreUtils ( exprOkForSpeculation, coreBindsSize ) import Bag import Literal ( Literal, literalType ) import DataCon ( DataCon, dataConRepType ) -import Id ( mayHaveNoBinding, isDeadBinder ) +import Id ( isDeadBinder ) import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId ) import VarSet import Subst ( mkTyVarSubst, substTy ) @@ -561,19 +561,7 @@ checkBndrIdInScope binder id checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var loc scope errs - | isLocallyDefined var - && not (var `elemVarSet` scope) - && not (isId var && mayHaveNoBinding var) - -- Micro-hack here... Class decls generate applications of their - -- dictionary constructor, but don't generate a binding for the - -- constructor (since it would never be used). After a single round - -- of simplification, these dictionary constructors have been - -- inlined (from their UnfoldInfo) to CoCons. Just between - -- desugaring and simplfication, though, they appear as naked, unbound - -- variables as the function in an application. - -- The hack here simply doesn't check for out-of-scope-ness for - -- data constructors (at least, in a function position). - -- Ditto primitive Ids + | mustHaveLocalBinding var && not (var `elemVarSet` scope) = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise = (Nothing,errs) diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index ebe3177c48..fa08ba481f 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -12,7 +12,7 @@ module CoreSyn ( mkLets, mkLams, mkApps, mkTyApps, mkValApps, mkVarApps, mkLit, mkIntLitInt, mkIntLit, - mkStringLit, mkStringLitFS, mkConApp, + mkConApp, varToCoreExpr, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId, @@ -40,7 +40,8 @@ module CoreSyn ( CoreRules(..), -- Representation needed by friends CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only RuleName, - emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules + emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, + isBuiltinRule ) where #include "HsVersions.h" @@ -52,7 +53,6 @@ import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) import Literal ( Literal(MachStr), mkMachInt ) import PrimOp ( PrimOp ) import DataCon ( DataCon, dataConId ) -import ThinAir ( unpackCStringId, unpackCString2Id ) import VarSet import Outputable \end{code} @@ -124,6 +124,20 @@ data CoreRules = Rules [CoreRule] VarSet -- Locally-defined free vars of RHSs +emptyCoreRules :: CoreRules +emptyCoreRules = Rules [] emptyVarSet + +isEmptyCoreRules :: CoreRules -> Bool +isEmptyCoreRules (Rules rs _) = null rs + +rulesRhsFreeVars :: CoreRules -> VarSet +rulesRhsFreeVars (Rules _ fvs) = fvs + +rulesRules :: CoreRules -> [CoreRule] +rulesRules (Rules rules _) = rules +\end{code} + +\begin{code} type RuleName = FAST_STRING data CoreRule @@ -136,17 +150,8 @@ data CoreRule -- and suchlike. It has no free variables. ([CoreExpr] -> Maybe (RuleName, CoreExpr)) -emptyCoreRules :: CoreRules -emptyCoreRules = Rules [] emptyVarSet - -isEmptyCoreRules :: CoreRules -> Bool -isEmptyCoreRules (Rules rs _) = null rs - -rulesRhsFreeVars :: CoreRules -> VarSet -rulesRhsFreeVars (Rules _ fvs) = fvs - -rulesRules :: CoreRules -> [CoreRule] -rulesRules (Rules rules _) = rules +isBuiltinRule (BuiltinRule _) = True +isBuiltinRule _ = False \end{code} @@ -329,8 +334,6 @@ mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkLit :: Literal -> Expr b mkIntLit :: Integer -> Expr b mkIntLitInt :: Int -> Expr b -mkStringLit :: String -> Expr b -- Makes a [Char] literal -mkStringLitFS :: FAST_STRING -> Expr b -- Makes a [Char] literal mkConApp :: DataCon -> [Arg b] -> Expr b mkLets :: [Bind b] -> Expr b -> Expr b mkLams :: [b] -> Expr b -> Expr b @@ -344,22 +347,6 @@ mkLets binds body = foldr Let body binds mkIntLit n = Lit (mkMachInt n) mkIntLitInt n = Lit (mkMachInt (toInteger n)) -mkStringLit str = mkStringLitFS (_PK_ str) - -mkStringLitFS str - | any is_NUL (_UNPK_ str) - = -- Must cater for NULs in literal string - mkApps (Var unpackCString2Id) - [Lit (MachStr str), - mkIntLitInt (_LENGTH_ str)] - - | otherwise - = -- No NULs in the string - App (Var unpackCStringId) (Lit (MachStr str)) - - where - is_NUL c = c == '\0' - varToCoreExpr :: CoreBndr -> Expr b varToCoreExpr v | isId v = Var v | otherwise = Type (mkTyVarTy v) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 7276e3480d..480edbb505 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -46,7 +46,7 @@ import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import BinderInfo ( ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial ) -import Id ( Id, idType, idFlavour, idUnique, isId, idWorkerInfo, +import Id ( Id, idType, idFlavour, isId, idWorkerInfo, idSpecialisation, idInlinePragma, idUnfolding, isPrimOpId_maybe ) @@ -57,9 +57,8 @@ import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists, isNeverInlinePrag ) -import TyCon ( tyConFamilySize ) import Type ( splitFunTy_maybe, isUnLiftedType ) -import Unique ( Unique, buildIdKey, augmentIdKey ) +import Unique ( Unique, buildIdKey, augmentIdKey, hasKey ) import Maybes ( maybeToBool ) import Bag import List ( maximumBy ) @@ -279,8 +278,8 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr -- Also if the function is a constant Id (constr or primop) -- compute discounts specially size_up_fun (Var fun) args - | idUnique fun == buildIdKey = buildSize - | idUnique fun == augmentIdKey = augmentSize + | fun `hasKey` buildIdKey = buildSize + | fun `hasKey` augmentIdKey = augmentSize | otherwise = case idFlavour fun of DataConId dc -> conSizeN (valArgCount args) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 4992e535f5..64ddad21e2 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -5,18 +5,18 @@ \begin{code} module CoreUtils ( - exprType, coreAltsType, - -- Construction mkNote, mkInlineMe, mkSCC, mkCoerce, bindNonRec, mkIfThenElse, mkAltExpr, + -- Properties of expressions + exprType, coreAltsType, exprArity, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprArity, exprIsConApp_maybe, - + exprIsConApp_maybe, idAppIsBottom, idAppIsCheap, + -- Expr transformation etaReduceExpr, exprEtaExpandArity, -- Size @@ -232,7 +232,6 @@ mkIfThenElse guard then_expr else_expr applications. Note that primop Ids aren't considered trivial unless - @exprIsBottom@ is true of expressions that are guaranteed to diverge diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index ce8adc2ebf..c6e847abe4 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -9,7 +9,8 @@ \begin{code} module PprCore ( - pprCoreExpr, pprParendExpr, pprIfaceUnfolding, + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprIdBndr, pprCoreBinding, pprCoreBindings, pprCoreRules, pprCoreRule ) where @@ -29,8 +30,10 @@ import IdInfo ( IdInfo, megaSeqIdInfo, occInfo, cprInfo, ppCprInfo, lbvarInfo, workerInfo, ppWorkerInfo ) -import DataCon ( isTupleCon, isUnboxedTupleCon ) +import DataCon ( dataConTyCon ) +import TyCon ( tupleTyConBoxity, isTupleTyCon ) import PprType ( pprParendType, pprTyVarBndr ) +import BasicTypes ( tupleParens ) import PprEnv import Outputable \end{code} @@ -66,6 +69,7 @@ pprCoreBindings = pprTopBinds pprCoreEnv pprCoreBinding = pprTopBind pprCoreEnv pprCoreExpr = ppr_noparend_expr pprCoreEnv pprParendExpr = ppr_parend_expr pprCoreEnv +pprArg = ppr_arg pprCoreEnv pprCoreEnv = initCoreEnv pprCoreBinder \end{code} @@ -73,16 +77,6 @@ pprCoreEnv = initCoreEnv pprCoreBinder Printer for unfoldings in interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprIfaceUnfolding :: CoreExpr -> SDoc -pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv - -- Notice that it's parenthesised - -pprIfaceArg = ppr_arg pprIfaceEnv - -pprIfaceEnv = initCoreEnv pprIfaceBinder -\end{code} - -\begin{code} instance Outputable b => Outputable (Bind b) where ppr bind = ppr_bind pprGenericEnv bind @@ -182,11 +176,13 @@ ppr_expr add_par pe expr@(App fun arg) Var f -> case isDataConId_maybe f of -- Notice that we print the *worker* -- for tuples in paren'd format. - Just dc | saturated && isTupleCon dc -> parens pp_tup_args - | saturated && isUnboxedTupleCon dc -> text "(#" <+> pp_tup_args <+> text "#)" - other -> add_par (hang (pOcc pe f) 4 pp_args) - where - saturated = length val_args == idArity f + Just dc | saturated && isTupleTyCon tc + -> tupleParens (tupleTyConBoxity tc) pp_tup_args + where + tc = dataConTyCon dc + saturated = length val_args == idArity f + + other -> add_par (hang (pOcc pe f) 4 pp_args) other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args) } @@ -282,15 +278,11 @@ ppr_expr add_par pe (Note (TermUsg u) expr) add_par (ppr u <+> ppr_noparend_expr pe expr) ppr_case_pat pe con@(DataAlt dc) args - | isTupleCon dc - = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow - | isUnboxedTupleCon dc - = hsep [text "(# " <> - hsep (punctuate comma (map ppr_bndr args)) <> - text " #)", - arrow] + | isTupleTyCon tc + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow where ppr_bndr = pBndr pe CaseBind + tc = dataConTyCon dc ppr_case_pat pe con args = ppr con <+> hsep (map ppr_bndr args) <+> arrow @@ -312,7 +304,7 @@ pprCoreBinder LetBind binder = vcat [sig, pragmas, ppr binder] where sig = pprTypedBinder binder - pragmas = ppIdInfo (idInfo binder) + pragmas = ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr = pprTypedBinder bndr @@ -320,10 +312,6 @@ pprCoreBinder LambdaBind bndr = pprTypedBinder bndr -- Case bound things don't get a signature or a herald pprCoreBinder CaseBind bndr = pprUntypedBinder bndr --- Used for printing interface-file unfoldings -pprIfaceBinder CaseBind binder = pprUntypedBinder binder -pprIfaceBinder other binder = pprTypedBinder binder - pprUntypedBinder binder | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder | otherwise = pprIdBndr binder @@ -347,8 +335,8 @@ pprIdBndr id = ppr id <+> \begin{code} -ppIdInfo :: IdInfo -> SDoc -ppIdInfo info +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo b info = hsep [ ppFlavourInfo (flavourInfo info), ppArityInfo a, @@ -357,7 +345,7 @@ ppIdInfo info ppStrictnessInfo s, ppCafInfo c, ppCprInfo m, - pprIfaceCoreRules p + pprCoreRules b p -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr @@ -374,24 +362,17 @@ ppIdInfo info \begin{code} pprCoreRules :: Id -> CoreRules -> SDoc -pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules) +pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules) -pprIfaceCoreRules :: CoreRules -> SDoc -pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules) - -pprCoreRule :: Maybe Id -> CoreRule -> SDoc -pprCoreRule maybe_fn (BuiltinRule _) +pprCoreRule :: SDoc -> CoreRule -> SDoc +pprCoreRule pp_fn (BuiltinRule _) = ifPprDebug (ptext SLIT("A built in rule")) -pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs) +pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs) = doubleQuotes (ptext name) <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)), - nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs) + nest 4 (pp_fn <+> sep (map pprArg tpl_args)), + nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs) ] <+> semi - where - pp_fn = case maybe_fn of - Just id -> ppr id - Nothing -> empty -- Interface file \end{code} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 62b33c6375..1f4c3b8495 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -35,7 +35,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules, seqRules ) -import CoreFVs ( exprFreeVars ) +import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) import TypeRep ( Type(..), TyNote(..), ) -- friend import Type ( ThetaType, PredType(..), ClassContext, @@ -45,7 +45,6 @@ import VarSet import VarEnv import Var ( setVarUnique, isId ) import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo ) -import Name ( isLocallyDefined ) import IdInfo ( IdInfo, isFragileOccInfo, specInfo, setSpecInfo, WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo @@ -189,7 +188,8 @@ lookupInScope in_scope v = case lookupVarEnv in_scope v of Just v' | v == v' -> v' -- Reached a fixed point | otherwise -> lookupInScope in_scope v' - Nothing -> v + Nothing -> WARN( mustHaveLocalBinding v, ppr v ) + v isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 821332a481..45a1ad8fcd 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -22,19 +22,18 @@ import DsUtils ( EquationInfo(..), tidyLitPat ) import Id ( idType ) -import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys, +import DataCon ( DataCon, dataConTyCon, dataConArgTys, dataConSourceArity, dataConFieldLabels ) import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc ) import Type ( Type, splitAlgTyConApp, mkTyVarTys, - isUnboxedType, splitTyConApp_maybe + splitTyConApp_maybe ) import TysWiredIn ( nilDataCon, consDataCon, - mkListTy, - mkTupleTy, tupleCon, - mkUnboxedTupleTy, unboxedTupleCon + mkListTy, mkTupleTy, tupleCon ) import Unique ( unboundKey ) -import TyCon ( tyConDataCons ) +import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) +import BasicTypes ( Boxity(..) ) import SrcLoc ( noSrcLoc ) import UniqSet import Outputable @@ -538,13 +537,13 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints) fixity = panic "Check.make_con: Guessing fixity" make_con (ConPat id _ _ _ pats) (ps,constraints) - | isTupleCon id = (TuplePatIn pats_con True : rest_pats, constraints) - | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints) - | otherwise = (ConPatIn name pats_con : rest_pats, constraints) + | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) + | otherwise = (ConPatIn name pats_con : rest_pats, constraints) where num_args = length pats name = getName id pats_con = take num_args ps rest_pats = drop num_args ps + tc = dataConTyCon id make_whole_con :: DataCon -> WarningPat @@ -591,15 +590,9 @@ simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] where list_ty = mkListTy ty -simplify_pat (TuplePat ps True) = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType ps)) [] [] - (map simplify_pat ps) - where - arity = length ps - -simplify_pat (TuplePat ps False) - = ConPat (unboxedTupleCon arity) - (mkUnboxedTupleTy arity (map outPatType ps)) [] [] +simplify_pat (TuplePat ps boxity) + = ConPat (tupleCon boxity arity) + (mkTupleTy boxity arity (map outPatType ps)) [] [] (map simplify_pat ps) where arity = length ps @@ -641,9 +634,9 @@ simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = simplify_pat (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat [] True) + 0 -> simplify_pat (TuplePat [] Boxed) 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (TuplePat dict_and_method_pats True) + _ -> simplify_pat (TuplePat dict_and_method_pats Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 2aa24b73f6..a870cd433c 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -10,7 +10,6 @@ module Desugar ( deSugar ) where import CmdLineOpts ( opt_D_dump_ds ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import HsCore ( UfRuleBody(..) ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl ) import TcModule ( TcResults(..) ) import CoreSyn @@ -77,11 +76,12 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) -> - mapDs dsRule rules `thenDs` \ rules' -> - let - ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds - fe_binders = bindersOfBinds fe_binds + let + ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds + fe_binders = bindersOfBinds fe_binds + local_binders = mkVarSet (bindersOfBinds ds_binds) in + mapDs (dsRule local_binders) rules `thenDs` \ rules' -> returnDs (ds_binds, rules', h_code, c_code, fe_binders) where auto_scc | opt_SccProfilingOn = TopLevel @@ -101,19 +101,19 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: TypecheckedRuleDecl -> DsM ProtoCoreRule -dsRule (IfaceRuleDecl fn (CoreRuleBody name all_vars args rhs) loc) - = returnDs (ProtoCoreRule False {- non-local -} fn - (Rule name all_vars args rhs)) +dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule +dsRule in_scope (IfaceRuleOut fn rule) + = returnDs (ProtoCoreRule False {- non-local -} fn rule) -dsRule (RuleDecl name sig_tvs vars lhs rhs loc) +dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> dsExpr rhs `thenDs` \ core_rhs -> returnDs (ProtoCoreRule True {- local -} fn - (Rule name all_vars args core_rhs)) + (Rule name tpl_vars args core_rhs)) where - all_vars = sig_tvs ++ [var | RuleBndr var <- vars] + tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars] + all_vars = in_scope `unionVarSet` mkVarSet tpl_vars ds_lhs all_vars lhs = let @@ -132,7 +132,7 @@ ds_lhs all_vars lhs -- Note recursion here... substitution won't terminate -- if there is genuine recursion... which there isn't - subst = mkSubst (mkVarSet all_vars) subst_env + subst = mkSubst all_vars subst_env body'' = substExpr subst body' in diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 11ca5a093a..6d488c44e7 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -28,7 +28,7 @@ import DataCon ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWr import CallConv import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, splitTyConApp_maybe, tyVarsOfType, mkForAllTys, - isNewType, repType, isUnLiftedType, mkFunTy, + isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp, Type ) import PprType ( {- instance Outputable Type -} ) @@ -36,14 +36,15 @@ import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy ) import TysWiredIn ( unitDataConId, stringTy, - unboxedPairDataCon, - mkUnboxedTupleTy, unboxedTupleCon, + unboxedSingletonDataCon, unboxedPairDataCon, + unboxedSingletonTyCon, unboxedPairTyCon, + mkTupleTy, tupleCon, boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId, unitTy ) import Literal ( mkMachInt ) import CStrings ( CLabelString ) -import Unique ( Unique, Uniquable(..), ioTyConKey ) +import Unique ( Unique, Uniquable(..), hasKey, ioTyConKey ) import VarSet ( varSetElems ) import Outputable \end{code} @@ -212,7 +213,7 @@ boxResult result_ty = case splitAlgTyConApp_maybe result_ty of -- The result is IO t, so wrap the result in an IO constructor - Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey + Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey -> mk_alt return_result (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> @@ -247,8 +248,8 @@ boxResult result_ty newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult")) - ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy] - the_alt = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs) + ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] + the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) in returnDs (ccall_res_ty, the_alt) @@ -258,7 +259,7 @@ boxResult result_ty newSysLocalDs prim_res_ty `thenDs` \ result_id -> let the_rhs = return_result (Var state_id) (wrap_result (Var result_id)) - ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty] + ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) in returnDs (ccall_res_ty, the_alt) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 5eefa471ab..94149c29c4 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -26,14 +26,16 @@ import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) import DsCCall ( dsCCall, resultWrapper ) import DsListComp ( dsListComp ) -import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr ) +import DsUtils ( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS, + mkConsExpr, mkNilExpr + ) import Match ( matchWrapper, matchSimply ) import CostCentre ( mkUserCC ) import FieldLabel ( FieldLabel ) import Id ( Id, idType, recordSelectorFieldLabel ) +import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels ) -import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId ) import TyCon ( isNewTyCon ) import DataCon ( isExistentialDataCon ) import Literal ( Literal(..), inIntRange ) @@ -42,14 +44,14 @@ import Type ( splitFunTys, mkTyConApp, isNotUsgTy, unUsgTy, splitAppTy, isUnLiftedType, Type ) -import TysWiredIn ( tupleCon, unboxedTupleCon, +import TysWiredIn ( tupleCon, listTyCon, mkListTy, charDataCon, charTy, stringTy, smallIntegerDataCon, isIntegerTy ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), Boxity(..) ) import Maybes ( maybeToBool ) -import Unique ( Uniquable(..), ratioTyConKey ) +import Unique ( Uniquable(..), hasKey, ratioTyConKey, addr2IntegerIdKey ) import Util ( zipEqual, zipWithEqual ) import Outputable @@ -160,7 +162,7 @@ dsExpr (HsLitOut (HsString s) _) -- "_" => build (\ c n -> c 'c' n) -- LATER dsExpr (HsLitOut (HsString str) _) - = returnDs (mkStringLitFS str) + = mkStringLitFS str dsExpr (HsLitOut (HsLitLit str) ty) = ASSERT( maybeToBool maybe_ty ) @@ -170,24 +172,23 @@ dsExpr (HsLitOut (HsLitLit str) ty) Just rep_ty = maybe_ty dsExpr (HsLitOut (HsInt i) ty) - = returnDs (mkIntegerLit i) + = mkIntegerLit i dsExpr (HsLitOut (HsFrac r) ty) - = returnDs (mkConApp ratio_data_con [Type integer_ty, - mkIntegerLit (numerator r), - mkIntegerLit (denominator r)]) + = mkIntegerLit (numerator r) `thenDs` \ num -> + mkIntegerLit (denominator r) `thenDs` \ denom -> + returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) = case (splitAlgTyConApp_maybe ty) of Just (tycon, [i_ty], [con]) - -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey) + -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) (con, i_ty) _ -> (panic "ratio_data_con", panic "integer_ty") - -- others where we know what to do: dsExpr (HsLitOut (HsIntPrim i) _) @@ -300,7 +301,7 @@ dsExpr (HsCase discrim matches src_loc) returnDs (Case core_discrim bndr alts) _ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) where - ubx_tuple_match (Match _ [TuplePat ps False{-unboxed-}] _ _) = True + ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True ubx_tuple_match _ = False dsExpr (HsCase discrim matches src_loc) @@ -379,12 +380,10 @@ dsExpr (ExplicitListOut ty xs) ASSERT( isNotUsgTy ty ) returnDs (mkConsExpr ty core_x core_xs) -dsExpr (ExplicitTuple expr_list boxed) +dsExpr (ExplicitTuple expr_list boxity) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> - returnDs (mkConApp ((if boxed - then tupleCon - else unboxedTupleCon) (length expr_list)) - (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs)) + returnDs (mkConApp (tupleCon boxity (length expr_list)) + (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs)) -- the above unUsgTy is *required* -- KSW 1999-04-07 dsExpr (ArithSeqOut expr (From from)) @@ -592,12 +591,14 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = do_expr expr locn `thenDs` \ expr2 -> go stmts `thenDs` \ rest -> let msg = ASSERT( isNotUsgTy b_ty ) - "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in + "Pattern match failure in do expression, " ++ showSDoc (ppr locn) + in + mkStringLit msg `thenDs` \ core_msg -> returnDs (mkIfThenElse expr2 rest (App (App (Var fail_id) (Type b_ty)) - (mkStringLit msg))) + core_msg)) go (ExprStmt expr locn : stmts) = do_expr expr locn `thenDs` \ expr2 -> @@ -659,12 +660,13 @@ var_pat _ = False \end{code} \begin{code} -mkIntegerLit :: Integer -> CoreExpr +mkIntegerLit :: Integer -> DsM CoreExpr mkIntegerLit i | inIntRange i -- Small enough, so start from an Int - = mkConApp smallIntegerDataCon [mkIntLit i] + = returnDs (mkConApp smallIntegerDataCon [mkIntLit i]) | otherwise -- Big, so start from a string - = App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i)))) + = dsLookupGlobalValue addr2IntegerIdKey `thenDs` \ addr2IntegerId -> + returnDs (App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i))))) \end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index c501beb358..d2c20a3267 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -30,7 +30,6 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), Provenance(..), ExportFlag(..) ) -import PrelInfo ( deRefStablePtr_NAME, returnIO_NAME, bindIO_NAME, makeStablePtr_NAME ) import Type ( unUsgTy, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, @@ -41,9 +40,12 @@ import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Var ( TyVar ) import TysPrim ( realWorldStatePrimTy, addrPrimTy ) import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, - unboxedTupleCon, addrDataCon + addrDataCon ) -import Unique +import Unique ( Uniquable(..), hasKey, + ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, + bindIOIdKey, makeStablePtrIdKey + ) import Maybes ( maybeToBool ) import Outputable \end{code} @@ -201,12 +203,12 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn -- If it's plain t, return (\x.returnIO x, IO t, t) (case splitTyConApp_maybe orig_res_ty of Just (ioTyCon, [res_ty]) - -> ASSERT( getUnique ioTyCon == ioTyConKey ) + -> ASSERT( ioTyCon `hasKey` ioTyConKey ) -- The function already returns IO t returnDs (\body -> body, orig_res_ty, res_ty) other -> -- The function returns t, so wrap the call in returnIO - dsLookupGlobalValue returnIO_NAME `thenDs` \ retIOId -> + dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId -> returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body], funResultTy (applyTy (idType retIOId) orig_res_ty), -- We don't have ioTyCon conveniently to hand @@ -221,13 +223,12 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn (if isDyn then newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value -> - dsLookupGlobalValue deRefStablePtr_NAME `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue deRefStablePtrIdKey `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> let the_deref_app = mkApps (Var deRefStablePtrId) [ Type stbl_ptr_to_ty, Var stbl_ptr ] - in - dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> - let + stbl_app cont = mkApps (Var bindIOId) [ Type stbl_ptr_to_ty , Type res_ty @@ -338,11 +339,11 @@ dsFExportDynamic i ty mod_name ext_name cconv = dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> + dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] in - dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> let stbl_app cont ret_ty diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index e5b823b32d..e413c58e81 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -19,7 +19,7 @@ import Type ( Type ) import DsMonad import DsUtils import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) -import Unique ( otherwiseIdKey, trueDataConKey, Uniquable(..) ) +import Unique ( otherwiseIdKey, trueDataConKey, hasKey, Uniquable(..) ) import Outputable \end{code} @@ -81,11 +81,9 @@ matchGuard (ExprStmt expr locn : should_be_null) ctx -- Turn an "otherwise" guard is a no-op matchGuard (GuardStmt (HsVar v) _ : stmts) ctx - | uniq == otherwiseIdKey - || uniq == trueDataConKey + | v `hasKey` otherwiseIdKey + || v `hasKey` trueDataConKey = matchGuard stmts ctx - where - uniq = getUnique v matchGuard (GuardStmt expr locn : stmts) ctx = matchGuard stmts ctx `thenDs` \ match_result -> @@ -107,4 +105,4 @@ Should {\em fail} if @e@ returns @D@ \begin{verbatim} f x | p <- e', let C y# = e, f y# = r1 | otherwise = r2 -\end{verbatim}
\ No newline at end of file +\end{verbatim} diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 5149297bcb..f7c78f04fb 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -14,7 +14,8 @@ import TcHsSyn ( TypecheckedPat, import Id ( idType, Id ) import Type ( Type ) -import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy ) +import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) +import BasicTypes ( Boxity(..) ) import Panic ( panic ) \end{code} @@ -29,8 +30,7 @@ outPatType (LazyPat pat) = outPatType pat outPatType (AsPat var pat) = idType var outPatType (ConPat _ ty _ _ _) = ty outPatType (ListPat ty _) = mkListTy ty -outPatType (TuplePat pats True) = mkTupleTy (length pats) (map outPatType pats) -outPatType (TuplePat pats False)= mkUnboxedTupleTy (length pats) (map outPatType pats) +outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) outPatType (RecPat _ ty _ _ _) = ty outPatType (LitPat lit ty) = ty outPatType (NPat lit ty _) = ty @@ -38,7 +38,7 @@ outPatType (NPlusKPat _ _ ty _ _) = ty outPatType (DictPat ds ms) = case (length ds_ms) of 0 -> unitTy 1 -> idType (head ds_ms) - n -> mkTupleTy n (map idType ds_ms) + n -> mkTupleTy Boxed n (map idType ds_ms) where ds_ms = ds ++ ms \end{code} diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index df05dd428c..8b79313f95 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -22,11 +22,11 @@ import CmdLineOpts ( opt_FoldrBuildOn ) import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id, TyVar ) -import PrelInfo ( foldrId, buildId ) import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar, alphaTy ) import TysWiredIn ( nilDataCon, consDataCon, listTyCon ) import Match ( matchSimply ) +import Unique ( foldrIdKey, buildIdKey ) import Outputable \end{code} @@ -51,12 +51,13 @@ dsListComp quals elt_ty n_ty = mkTyVarTy n_tyvar c_ty = mkFunTys [elt_ty, n_ty] n_ty in - newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] -> + newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] -> - dfListComp c n quals `thenDs` \ result -> + dfListComp c n quals `thenDs` \ result -> - returnDs (Var buildId `App` Type elt_ty - `App` mkLams [n_tyvar, c, n] result) + dsLookupGlobalValue buildIdKey `thenDs` \ build_id -> + returnDs (Var build_id `App` Type elt_ty + `App` mkLams [n_tyvar, c, n] result) \end{code} %************************************************************************ @@ -207,12 +208,13 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return + dsLookupGlobalValue foldrIdKey `thenDs` \ foldr_id -> returnDs ( - Var foldrId `App` Type x_ty - `App` Type b_ty - `App` mkLams [x, b] core_expr - `App` Var n_id - `App` core_list1 + Var foldr_id `App` Type x_ty + `App` Type b_ty + `App` mkLams [x, b] core_expr + `App` Var n_id + `App` core_list1 ) \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index b11166ac54..ae58ca9eb6 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -41,7 +41,7 @@ import Type ( Type ) import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, UniqSM, UniqSupply ) import Unique ( Unique ) -import UniqFM ( lookupWithDefaultUFM ) +import UniqFM ( lookupWithDefaultUFM_Directly ) import Util ( zipWithEqual ) infixr 9 `thenDs` @@ -201,13 +201,11 @@ getModuleDs us genv loc mod warns = (mod, warns) \end{code} \begin{code} -dsLookupGlobalValue :: Name -> DsM Id -dsLookupGlobalValue name us genv loc mod warns - = case maybeWiredInIdName name of - Just id -> (id, warns) - Nothing -> (lookupWithDefaultUFM genv def name, warns) +dsLookupGlobalValue :: Unique -> DsM Id +dsLookupGlobalValue key us genv loc mod warns + = (lookupWithDefaultUFM_Directly genv def key, warns) where - def = pprPanic "tcLookupGlobalValue:" (ppr name) + def = pprPanic "tcLookupGlobalValue:" (ppr key) \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 181beeb3dd..cdd1fd3b3a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -21,6 +21,7 @@ module DsUtils ( mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkErrorAppDs, mkNilExpr, mkConsExpr, + mkStringLit, mkStringLitFS, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -41,7 +42,7 @@ import DsMonad import CoreUtils ( exprType, mkIfThenElse ) import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import Id ( idType, Id, mkWildId ) -import Literal ( Literal ) +import Literal ( Literal(..) ) import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, dataConId, splitProductType_maybe @@ -67,7 +68,9 @@ import TysWiredIn ( nilDataCon, consDataCon, addrTy, addrDataCon, wordTy, wordDataCon ) +import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import Unique ( unpackCStringIdKey, unpackCString2IdKey ) import Outputable \end{code} @@ -376,8 +379,29 @@ mkErrorAppDs err_id ty msg let full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) in - returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg]) + mkStringLit full_msg `thenDs` \ core_msg -> + returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg]) -- unUsgTy *required* -- KSW 1999-04-07 + +mkStringLit :: String -> DsM CoreExpr +mkStringLit str = mkStringLitFS (_PK_ str) + +mkStringLitFS :: FAST_STRING -> DsM CoreExpr +mkStringLitFS str + | any is_NUL (_UNPK_ str) + = -- Must cater for NULs in literal string + dsLookupGlobalValue unpackCString2IdKey `thenDs` \ unpack_id -> + returnDs (mkApps (Var unpack_id) + [Lit (MachStr str), + mkIntLitInt (_LENGTH_ str)]) + + | otherwise + = -- No NULs in the string + dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id -> + returnDs (App (Var unpack_id) (Lit (MachStr str))) + + where + is_NUL c = c == '\0' \end{code} %************************************************************************ @@ -421,9 +445,10 @@ mkSelectorBinds pat val_expr let full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat]) in + mkStringLit full_msg `thenDs` \ core_msg -> mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds -> returnDs ( (val_var, val_expr) : - (msg_var, mkStringLit full_msg) : + (msg_var, core_msg) : binds ) @@ -455,7 +480,7 @@ mkSelectorBinds pat val_expr binder_ty = idType bndr_var error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var] - is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps + is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps is_simple_pat (VarPat _) = True is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps] @@ -476,7 +501,7 @@ mkTupleExpr :: [Id] -> CoreExpr mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id -mkTupleExpr ids = mkConApp (tupleCon (length ids)) +mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -503,7 +528,7 @@ mkTupleSelector [var] should_be_the_same_var scrut_var scrut mkTupleSelector vars the_var scrut_var scrut = ASSERT( not (null vars) ) - Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)] + Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index e69c50adc2..7d0e47fffd 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -37,9 +37,9 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, doubleTy, tupleCon, doubleDataCon, addrTy, - addrDataCon, wordTy, wordDataCon, - mkUnboxedTupleTy, unboxedTupleCon + addrDataCon, wordTy, wordDataCon ) +import BasicTypes ( Boxity(..) ) import UniqSet import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) import Outputable @@ -499,29 +499,20 @@ tidy1 v (ListPat ty pats) match_result (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats True{-boxed-}) match_result +tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats tuple_ConPat - = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType pats)) [] [] - pats - -tidy1 v (TuplePat pats False{-unboxed-}) match_result - = returnDs (tuple_ConPat, match_result) - where - arity = length pats - tuple_ConPat - = ConPat (unboxedTupleCon arity) - (mkUnboxedTupleTy arity (map outPatType pats)) [] [] + = ConPat (tupleCon boxity arity) + (mkTupleTy boxity arity (map outPatType pats)) [] [] pats tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of - 0 -> tidy1 v (TuplePat [] True) match_result + 0 -> tidy1 v (TuplePat [] Boxed) match_result 1 -> tidy1 v (head dict_and_method_pats) match_result - _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result + _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 4e2f98bcbd..1e7f80bfb5 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -14,7 +14,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs ) -- friends: -import HsTypes ( HsType, cmpHsType ) +import HsTypes ( HsType ) import HsImpExp ( IE(..), ieName ) import CoreSyn ( CoreExpr ) import PprCore () -- Instances for Outputable @@ -265,16 +265,11 @@ data Sig name | FixSig (FixitySig name) -- Fixity declaration - | DeprecSig (Deprecation name) -- DEPRECATED - SrcLoc - -data FixitySig name = FixitySig name Fixity SrcLoc --- We use exported entities for things to deprecate. Cunning trick (hack?): --- `IEModuleContents undefined' is used for module deprecation. -data Deprecation name = Deprecation (IE name) DeprecTxt +data FixitySig name = FixitySig name Fixity SrcLoc -type DeprecTxt = FAST_STRING -- reason/explanation for deprecation +instance Eq name => Eq (FixitySig name) where + (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2 \end{code} \begin{code} @@ -298,14 +293,6 @@ sigForThisGroup ns sig Just n | isUnboundName n -> True -- Don't complain about an unbound name again | otherwise -> n `elemNameSet` ns -sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name] -sigsForMe f sigs - = filter sig_for_me sigs - where - sig_for_me sig = case sigName sig of - Nothing -> False - Just n -> f n - sigName :: Sig name -> Maybe name sigName (Sig n _ _) = Just n sigName (ClassOpSig n _ _ _ _) = Just n @@ -313,9 +300,6 @@ sigName (SpecSig n _ _) = Just n sigName (InlineSig n _ _) = Just n sigName (NoInlineSig n _ _) = Just n sigName (FixSig (FixitySig n _ _)) = Just n -sigName (DeprecSig (Deprecation d _) _) = case d of - IEModuleContents _ -> Nothing - other -> Just (ieName d) sigName other = Nothing isFixitySig :: Sig name -> Bool @@ -332,7 +316,6 @@ isPragSig (SpecSig _ _ _) = True isPragSig (InlineSig _ _ _) = True isPragSig (NoInlineSig _ _ _) = True isPragSig (SpecInstSig _ _) = True -isPragSig (DeprecSig _ _) = True isPragSig other = False \end{code} @@ -344,7 +327,6 @@ hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) -hsSigDoc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc) \end{code} \begin{code} @@ -355,8 +337,10 @@ ppr_sig :: Outputable name => Sig name -> SDoc ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -ppr_sig (ClassOpSig var _ _ ty _) - = sep [ppr var <+> dcolon, nest 4 (ppr ty)] +ppr_sig (ClassOpSig var _ dm ty _) + = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)] + where + pp_dm = if dm then equals else empty -- Default-method indicator ppr_sig (SpecSig var ty _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], @@ -374,17 +358,10 @@ ppr_sig (SpecInstSig ty _) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (DeprecSig deprec _) = ppr deprec instance Outputable name => Outputable (FixitySig name) where ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] -instance Outputable name => Outputable (Deprecation name) where - ppr (Deprecation (IEModuleContents _) txt) - = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"] - ppr (Deprecation thing txt) - = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] - ppr_phase :: Maybe Int -> SDoc ppr_phase Nothing = empty ppr_phase (Just n) = int n @@ -394,37 +371,16 @@ Checking for distinct signatures; oh, so boring \begin{code} -cmpHsSig :: Sig Name -> Sig Name -> Ordering -cmpHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 -cmpHsSig (DeprecSig (Deprecation ie1 _) _) - (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2 -cmpHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2 -cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2 - -cmpHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 -cmpHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) +eqHsSig :: Sig Name -> Sig Name -> Bool +eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 +eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2 +eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2 + +eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2 +eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) = -- may have many specialisations for one value; -- but not ones that are exactly the same... - thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) - -cmpHsSig other_1 other_2 -- Tags *must* be different - | (sig_tag other_1) _LT_ (sig_tag other_2) = LT - | otherwise = GT - -cmp_ie :: IE Name -> IE Name -> Ordering -cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2 -cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2 -cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2 --- Hmmm... -cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2 -cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ - -sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) -sig_tag (SpecSig n1 _ _) = ILIT(2) -sig_tag (InlineSig n1 _ _) = ILIT(3) -sig_tag (NoInlineSig n1 _ _) = ILIT(4) -sig_tag (SpecInstSig _ _) = ILIT(5) -sig_tag (FixSig _) = ILIT(6) -sig_tag (DeprecSig _ _) = ILIT(7) -sig_tag _ = panic# "tag(RnBinds)" + (n1 == n2) && (ty1 == ty2) + +eqHsSig other_1 other_2 = False \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index d7f1317d1f..838bbb38bb 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -14,25 +14,43 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), - HsIdInfo(..), HsStrictnessInfo(..), - IfaceSig(..), UfRuleBody(..) + HsIdInfo(..), + IfaceSig(..), + + eq_ufExpr, eq_ufBinders, pprUfExpr, + + toUfExpr, toUfBndr ) where #include "HsVersions.h" -- friends: -import HsTypes ( HsType, pprParendHsType ) +import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, + HsTupCon(..), hsTupParens, + emptyEqHsEnv, extendEqHsEnv, eqListBy, + eq_hsType, eq_hsVar, eq_hsVars + ) -- others: -import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo ) -import CoreSyn ( CoreBndr, CoreExpr ) -import Demand ( Demand ) -import Literal ( Literal ) +import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe ) +import Var ( varType, isId ) +import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, + pprInlinePragInfo, ppArityInfo, ppStrictnessInfo + ) +import RdrName ( RdrName ) +import Name ( Name, toRdrName ) +import CoreSyn +import CostCentre ( pprCostCentreCore ) +import PrimOp ( PrimOp(CCallOp) ) +import Demand ( Demand, StrictnessInfo ) +import Literal ( Literal, maybeLitLit ) import PrimOp ( CCall, pprCCallOp ) -import Type ( Kind ) -import PprType ( {- instance Outputable Type -} ) +import DataCon ( dataConTyCon ) +import TyCon ( isTupleTyCon, tupleTyConBoxity ) +import Type ( Type, Kind ) import CostCentre import SrcLoc ( SrcLoc ) +import BasicTypes ( Arity ) import Outputable \end{code} @@ -46,9 +64,9 @@ import Outputable data UfExpr name = UfVar name | UfType (HsType name) - | UfTuple name [UfExpr name] -- Type arguments omitted - | UfLam (UfBinder name) (UfExpr name) - | UfApp (UfExpr name) (UfExpr name) + | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted + | UfLam (UfBinder name) (UfExpr name) + | UfApp (UfExpr name) (UfExpr name) | UfCase (UfExpr name) name [UfAlt name] | UfLet (UfBinding name) (UfExpr name) | UfNote (UfNote name) (UfExpr name) @@ -65,6 +83,7 @@ type UfAlt name = (UfConAlt name, [name], UfExpr name) data UfConAlt name = UfDefault | UfDataAlt name + | UfTupleAlt (HsTupCon name) | UfLitAlt Literal | UfLitLitAlt FAST_STRING (HsType name) @@ -81,54 +100,210 @@ data UfBinder name %************************************************************************ %* * -\subsection[HsCore-print]{Printing Core unfoldings} +\subsection{Converting from Core to UfCore} %* * %************************************************************************ \begin{code} -instance Outputable name => Outputable (UfExpr name) where - ppr (UfVar v) = ppr v - ppr (UfLit l) = ppr l +toUfExpr :: CoreExpr -> UfExpr RdrName +toUfExpr (Var v) = toUfVar v +toUfExpr (Lit l) = case maybeLitLit l of + Just (s,ty) -> UfLitLit s (toHsType ty) + Nothing -> UfLit l +toUfExpr (Type ty) = UfType (toHsType ty) +toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b) +toUfExpr (App f a) = toUfApp f [a] +toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as) +toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e) +toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e) + +--------------------- +toUfNote (SCC cc) = UfSCC cc +toUfNote (Coerce t1 _) = UfCoerce (toHsType t1) +toUfNote InlineCall = UfInlineCall +toUfNote InlineMe = UfInlineMe + +--------------------- +toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r) +toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs] + +--------------------- +toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r) + +--------------------- +toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) + | otherwise = UfDataAlt (toRdrName dc) + where + tc = dataConTyCon dc + +toUfCon (LitAlt l) = case maybeLitLit l of + Just (s,ty) -> UfLitLitAlt s (toHsType ty) + Nothing -> UfLitAlt l +toUfCon DEFAULT = UfDefault + +--------------------- +toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x)) + | otherwise = UfTyBinder (toRdrName x) (varType x) + +--------------------- +toUfApp (App f a) as = toUfApp f (a:as) +toUfApp (Var v) as + = case isDataConId_maybe v of + -- We convert the *worker* for tuples into UfTuples + Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args + where + val_args = dropWhile isTypeArg as + saturated = length val_args == idArity v + tup_args = map toUfExpr val_args + tc = dataConTyCon dc + ; + + other -> mkUfApps (toUfVar v) as + +toUfApp e as = mkUfApps (toUfExpr e) as + +mkUfApps = foldl (\f a -> UfApp f (toUfExpr a)) + +--------------------- +toUfVar v = case isPrimOpId_maybe v of + -- Ccalls has special syntax + Just (CCallOp cc) -> UfCCall cc (toHsType (idType v)) + other -> UfVar (toRdrName v) +\end{code} - ppr (UfLitLit l ty) = ppr l - ppr (UfCCall cc ty) = pprCCallOp cc - ppr (UfType ty) = char '@' <+> pprParendHsType ty +%************************************************************************ +%* * +\subsection[HsCore-print]{Printing Core unfoldings} +%* * +%************************************************************************ - ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as))) +\begin{code} +instance Outputable name => Outputable (UfExpr name) where + ppr e = pprUfExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +pprUfExpr add_par (UfVar v) = ppr v +pprUfExpr add_par (UfLit l) = ppr l +pprUfExpr add_par (UfLitLit l ty) = ppr l +pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty) +pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty +pprUfExpr add_par (UfLam b body) = add_par (hsep [char '\\', ppr b, ptext SLIT("->"), pprUfExpr noParens body]) +pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg) +pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as) + +pprUfExpr add_par (UfCase scrut bndr alts) + = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr, + braces (hsep (map pp_alt alts))]) + where + pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs + pp_alt (c, bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs - ppr (UfLam b body) - = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body] + ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi - ppr (UfApp fun arg) = ppr fun <+> ppr arg +pprUfExpr add_par (UfLet (UfNonRec b rhs) body) + = add_par (hsep [ptext SLIT("let"), + braces (ppr b <+> equals <+> pprUfExpr noParens rhs), + ptext SLIT("in"), pprUfExpr noParens body]) - ppr (UfCase scrut bndr alts) - = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr, - braces (hsep (punctuate semi (map pp_alt alts)))] +pprUfExpr add_par (UfLet (UfRec pairs) body) + = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)), + ptext SLIT("in"), pprUfExpr noParens body]) where - pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs] - - ppr_arrow = ptext SLIT("->") + pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi - ppr (UfLet (UfNonRec b rhs) body) - = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body] - ppr (UfLet (UfRec pairs) body) - = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body] - where - pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs] +pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body) - ppr (UfNote note body) - = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body] +instance Outputable name => Outputable (UfNote name) where + ppr (UfSCC cc) = pprCostCentreCore cc + ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty + ppr UfInlineCall = ptext SLIT("__inline_call") + ppr UfInlineMe = ptext SLIT("__inline_me") instance Outputable name => Outputable (UfConAlt name) where - ppr UfDefault = text "DEFAULT" + ppr UfDefault = text "__DEFAULT" ppr (UfLitAlt l) = ppr l ppr (UfLitLitAlt l ty) = ppr l ppr (UfDataAlt d) = ppr d instance Outputable name => Outputable (UfBinder name) where - ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty] - ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind] + ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] + ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind +\end{code} + + +%************************************************************************ +%* * +\subsection[HsCore-print]{Equality, for interface file checking +%* * +%************************************************************************ + +\begin{code} +instance Ord name => Eq (UfExpr name) where + (==) a b = eq_ufExpr emptyEqHsEnv a b + +----------------- +eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k + = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2) +eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k + = k1==k2 && k (extendEqHsEnv env n1 n2) +eq_ufBinder _ _ _ _ = False + +----------------- +eq_ufBinders env [] [] k = k env +eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k) +eq_ufBinders env _ _ _ = False + +----------------- +eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2 +eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2 +eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2 +eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2 +eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2 +eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2 +eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2) +eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2 + +eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2) + = eq_ufExpr env s1 s2 && + eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2 + where + eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2) + = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2) + +eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2) + = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2) + +eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2) + = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2) + where + (bs1,rs1) = unzip as1 + (bs2,rs2) = unzip as2 + +eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2) + = eq_ufNote n1 n2 && eq_ufExpr env r1 r2 + where + eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2 + eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2 + eq_ufNote UfInlineCall UfInlineCall = True + eq_ufNote UfInlineMe UfInlineMe = True + eq_ufNote _ _ = False + +eq_ufExpr env _ _ = False + +----------------- +eq_ufConAlt env UfDefault UfDefault = True +eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2 +eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2 +eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2 +eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2 +eq_ufConAlt env _ _ = False \end{code} @@ -139,44 +314,44 @@ instance Outputable name => Outputable (UfBinder name) where %************************************************************************ \begin{code} -data IfaceSig name - = IfaceSig name - (HsType name) - [HsIdInfo name] - SrcLoc +data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc + +instance Ord name => Eq (IfaceSig name) where + (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 instance (Outputable name) => Outputable (IfaceSig name) where - ppr (IfaceSig var ty info _) - = hang (hsep [ppr var, dcolon]) - 4 (ppr ty $$ ifPprDebug (vcat (map ppr info))) + ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] +\end{code} + + +%************************************************************************ +%* * +\subsection{Rules in interface files} +%* * +%************************************************************************ + +\begin{code} +pprHsIdInfo [] = empty +pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}") data HsIdInfo name = HsArity ArityInfo - | HsStrictness HsStrictnessInfo + | HsStrictness StrictnessInfo | HsUnfold InlinePragInfo (UfExpr name) | HsUpdate UpdateInfo - | HsSpecialise (UfRuleBody name) | HsNoCafRefs | HsCprInfo | HsWorker name -- Worker, if any + deriving( Eq ) +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. instance Outputable name => Outputable (HsIdInfo name) where - ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf - ppr other = empty -- Havn't got around to this yet - -data HsStrictnessInfo - = HsStrictnessInfo ([Demand], Bool) - | HsBottom + ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf) + ppr (HsArity arity) = ppArityInfo arity + ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str + ppr HsNoCafRefs = ptext SLIT("__C") + ppr HsCprInfo = ptext SLIT("__M") + ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w \end{code} - -%************************************************************************ -%* * -\subsection{Rules in interface files} -%* * -%************************************************************************ - -\begin{code} -data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck - | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck -\end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 7f47891852..7fb207ee9a 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -13,27 +13,33 @@ module HsDecls ( ExtName(..), isDynamicExtName, extNameStatic, ConDecl(..), ConDetails(..), BangType(..), IfaceSig(..), SpecDataSig(..), - hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls + DeprecDecl(..), DeprecTxt, + hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule ) where #include "HsVersions.h" -- friends: -import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds ) +import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..), nullMonoBinds ) import HsExpr ( HsExpr ) import HsPragmas ( DataPragmas, ClassPragmas ) +import HsImpExp ( IE(..) ) import HsTypes -import HsCore ( UfExpr, UfBinder, IfaceSig(..), UfRuleBody ) +import PprCore ( pprCoreRule ) +import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr ) +import CoreSyn ( CoreRule(..) ) import BasicTypes ( Fixity, NewOrData(..) ) import CallConv ( CallConv, pprCallConv ) -import Var ( TyVar ) +import Var ( TyVar, Id ) +import Name ( toRdrName ) -- others: import PprType -import {-# SOURCE #-} FunDeps ( pprFundeps ) +import FunDeps ( pprFundeps ) +import Class ( FunDep ) import CStrings ( CLabelString, pprCLabelString ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Util \end{code} @@ -53,6 +59,7 @@ data HsDecl name pat | ForD (ForeignDecl name) | SigD (IfaceSig name) | FixD (FixitySig name) + | DeprecD (DeprecDecl name) | RuleD (RuleDecl name pat) -- NB: all top-level fixity decls are contained EITHER @@ -74,18 +81,18 @@ data HsDecl name pat hsDeclName :: (Outputable name, Outputable pat) => HsDecl name pat -> name #endif -hsDeclName (TyClD decl) = tyClDeclName decl -hsDeclName (SigD (IfaceSig name _ _ _)) = name -hsDeclName (InstD (InstDecl _ _ _ name _)) = name -hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name -hsDeclName (FixD (FixitySig name _ _)) = name +hsDeclName (TyClD decl) = tyClDeclName decl +hsDeclName (SigD (IfaceSig name _ _ _)) = name +hsDeclName (InstD (InstDecl _ _ _ name _)) = name +hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name +hsDeclName (FixD (FixitySig name _ _)) = name -- Others don't make sense #ifdef DEBUG hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #endif tyClDeclName :: TyClDecl name pat -> name -tyClDeclName (TyData _ _ name _ _ _ _ _) = name +tyClDeclName (TyData _ _ name _ _ _ _ _ _) = name tyClDeclName (TySynonym name _ _ _) = name tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name \end{code} @@ -102,6 +109,15 @@ instance (Outputable name, Outputable pat) ppr (ForD fd) = ppr fd ppr (FixD fd) = ppr fd ppr (RuleD rd) = ppr rd + ppr (DeprecD dd) = ppr dd +\end{code} + +\begin{code} +instance Ord name => Eq (HsDecl name pat) where + -- Used only when comparing interfaces, + -- at which time only signature and type/class decls + (SigD s1) == (SigD s2) = s1 == s2 + (TyClD d1) == (TyClD d2) = d1 == d2 \end{code} @@ -116,8 +132,9 @@ data TyClDecl name pat = TyData NewOrData (HsContext name) -- context name -- type constructor - [HsTyVar name] -- type variables + [HsTyVarBndr name] -- type variables [ConDecl name] -- data constructors (empty if abstract) + Int -- Number of data constructors (valid even if type is abstract) (Maybe [name]) -- derivings; Nothing => not specified -- (i.e., derive default); Just [] => derive -- *nothing*; Just <list> => as you would @@ -126,14 +143,14 @@ data TyClDecl name pat SrcLoc | TySynonym name -- type constructor - [HsTyVar name] -- type variables + [HsTyVarBndr name] -- type variables (HsType name) -- synonym expansion SrcLoc | ClassDecl (HsContext name) -- context... name -- name of the class - [HsTyVar name] -- the class type variables - [([name], [name])] -- functional dependencies + [HsTyVarBndr name] -- the class type variables + [FunDep name] -- functional dependencies [Sig name] -- methods' signatures (MonoBinds name pat) -- default methods (ClassPragmas name) @@ -141,6 +158,37 @@ data TyClDecl name pat -- and superclass selectors for this class. -- These are filled in as the ClassDecl is made. SrcLoc + +instance Ord name => Eq (TyClDecl name pat) where + -- Used only when building interface files + (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _) + (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _) + = n1 == n2 && + nd1 == nd2 && + eqWithHsTyVars tvs1 tvs2 (\ env -> + eq_hsContext env cxt1 cxt2 && + eqListBy (eq_ConDecl env) cons1 cons2 + ) + + (==) (TySynonym n1 tvs1 ty1 _) + (TySynonym n2 tvs2 ty2 _) + = n1 == n2 && + eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2) + + (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ _ _ _) + (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ _ _ _) + = n1 == n2 && + eqWithHsTyVars tvs1 tvs2 (\ env -> + eq_hsContext env cxt1 cxt2 && + eqListBy (eq_hsFD env) fds1 fds2 && + eqListBy (eq_cls_sig env) sigs1 sigs2 + ) + +eq_hsFD env (ns1,ms1) (ns2,ms2) + = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2 + +eq_cls_sig env (ClassOpSig n1 _ b1 ty1 _) (ClassOpSig n2 _ b2 ty2 _) + = n1==n2 && b1==b2 && eq_hsType env ty1 ty2 \end{code} \begin{code} @@ -148,8 +196,8 @@ countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls], - length [() | TyData DataType _ _ _ _ _ _ _ <- decls], - length [() | TyData NewType _ _ _ _ _ _ _ <- decls], + length [() | TyData DataType _ _ _ _ _ _ _ _ <- decls], + length [() | TyData NewType _ _ _ _ _ _ _ _ <- decls], length [() | TySynonym _ _ _ _ <- decls]) isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool @@ -157,8 +205,8 @@ isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool isSynDecl (TySynonym _ _ _ _) = True isSynDecl other = False -isDataDecl (TyData _ _ _ _ _ _ _ _) = True -isDataDecl other = False +isDataDecl (TyData _ _ _ _ _ _ _ _ _) = True +isDataDecl other = False isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True isClassDecl other = False @@ -169,13 +217,13 @@ instance (Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where ppr (TySynonym tycon tyvars mono_ty src_loc) - = hang (pp_decl_head SLIT("type") empty tycon tyvars) + = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals) 4 (ppr mono_ty) - ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) + ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc) = pp_tydecl - (pp_decl_head keyword (pprHsContext context) tycon tyvars) - (pp_condecls condecls) + (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals) + (pp_condecls condecls ncons) derivings where keyword = case new_or_data of @@ -188,21 +236,19 @@ instance (Outputable name, Outputable pat) | otherwise -- Laid out = sep [hsep [top_matter, ptext SLIT("where {")], - nest 4 (vcat [sep (map ppr_sig sigs), - ppr methods, - char '}'])] + nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])] where - top_matter = hsep [ptext SLIT("class"), pprHsContext context, - ppr clas, hsep (map (ppr) tyvars), pprFundeps fds] + top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds ppr_sig sig = ppr sig <> semi + pp_methods = getPprStyle $ \ sty -> + if ifaceStyle sty then empty else ppr methods + +pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc +pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_decl_head str pp_context tycon tyvars - = hsep [ptext str, pp_context, ppr tycon, - interppSP tyvars, ptext SLIT("=")] - -pp_condecls [] = empty -- Curious! -pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs) +pp_condecls [] ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}") +pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs) pp_tydecl pp_head pp_decl_rhs derivings = hang pp_head 4 (sep [ @@ -244,7 +290,7 @@ data ConDecl name name -- Name of the constructor's 'worker Id' -- Filled in as the ConDecl is built - [HsTyVar name] -- Existentially quantified type variables + [HsTyVarBndr name] -- Existentially quantified type variables (HsContext name) -- ...and context -- If both are empty then there are no existentials @@ -270,12 +316,36 @@ data BangType name = Banged (HsType name) -- HsType: to allow Haskell extensions | Unbanged (HsType name) -- (MonoType only needed for straight Haskell) | Unpacked (HsType name) -- Field is strict and to be unpacked if poss. + + +eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _) + (ConDecl n2 _ tvs2 cxt2 cds2 _) + = n1 == n2 && + (eqWithHsTyVars tvs1 tvs2 $ \ env -> + eq_hsContext env cxt1 cxt2 && + eq_ConDetails env cds1 cds2) + +eq_ConDetails env (VanillaCon bts1) (VanillaCon bts2) + = eqListBy (eq_btype env) bts1 bts2 +eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2) + = eq_btype env bta1 bta2 && eq_btype env btb1 btb2 +eq_ConDetails env (RecCon fs1) (RecCon fs2) + = eqListBy (eq_fld env) fs1 fs2 +eq_ConDetails env (NewCon t1 mn1) (NewCon t2 mn2) + = eq_hsType env t1 t2 && mn1 == mn2 +eq_ConDetails env _ _ = False + +eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 + +eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2 +eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2 +eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2 \end{code} \begin{code} instance (Outputable name) => Outputable (ConDecl name) where ppr (ConDecl con _ tvs cxt con_details loc) - = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details] + = sep [pprHsForAll tvs cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] @@ -334,14 +404,21 @@ instance (Outputable name, Outputable pat) ppr (InstDecl inst_ty binds uprags dfun_name src_loc) = getPprStyle $ \ sty -> - if ifaceStyle sty || (nullMonoBinds binds && null uprags) then - hsep [ptext SLIT("instance"), ppr inst_ty] + if ifaceStyle sty then + hsep [ptext SLIT("instance"), ppr inst_ty, equals, ppr dfun_name] else vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], nest 4 (ppr uprags), nest 4 (ppr binds) ] \end{code} +\begin{code} +instance Ord name => Eq (InstDecl name pat) where + -- Used for interface comparison only, so don't compare bindings + (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _) + = inst_ty1 == inst_ty2 && dfun1 == dfun2 +\end{code} + %************************************************************************ %* * @@ -431,7 +508,7 @@ instance Outputable ExtName where \begin{code} data RuleDecl name pat - = RuleDecl + = HsRule -- Source rule FAST_STRING -- Rule name [name] -- Forall'd tyvars, filled in by the renamer with -- tyvars mentioned in sigs; then filled out by typechecker @@ -440,18 +517,33 @@ data RuleDecl name pat (HsExpr name pat) -- RHS SrcLoc - | IfaceRuleDecl -- One that's come in from an interface file - name - (UfRuleBody name) + | IfaceRule -- One that's come in from an interface file; pre-typecheck + FAST_STRING + [UfBinder name] -- Tyvars and term vars + name -- Head of lhs + [UfExpr name] -- Args of LHS + (UfExpr name) -- Pre typecheck SrcLoc + | IfaceRuleOut -- Post typecheck + name -- Head of LHS + CoreRule + + data RuleBndr name = RuleBndr name | RuleBndrSig name (HsType name) +instance Ord name => Eq (RuleDecl name pat) where + -- Works for IfaceRules only; used when comparing interface file versions + (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _) + = n1==n2 && f1 == f2 && + eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> + eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) + instance (Outputable name, Outputable pat) => Outputable (RuleDecl name pat) where - ppr (RuleDecl name tvs ns lhs rhs loc) + ppr (HsRule name tvs ns lhs rhs loc) = sep [text "{-# RULES" <+> doubleQuotes (ptext name), pp_forall, ppr lhs, equals <+> ppr rhs, text "#-}" ] @@ -460,9 +552,49 @@ instance (Outputable name, Outputable pat) | otherwise = text "forall" <+> fsep (map ppr tvs ++ map ppr ns) <> dot - ppr (IfaceRuleDecl var body loc) = text "An imported rule..." + + ppr (IfaceRule name tpl_vars fn tpl_args rhs loc) + = hsep [ doubleQuotes (ptext name), + ptext SLIT("__forall") <+> braces (interppSP tpl_vars), + ppr fn <+> sep (map (pprUfExpr parens) tpl_args), + ptext SLIT("=") <+> ppr rhs + ] <+> semi + + ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule instance Outputable name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty + +toHsRule id (BuiltinRule _) + = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) + +toHsRule id (Rule name bndrs args rhs) + = IfaceRule name (map toUfBndr bndrs) (toRdrName id) + (map toUfExpr args) (toUfExpr rhs) noSrcLoc + +bogusIfaceRule id + = IfaceRule SLIT("bogus") [] (toRdrName id) [] (UfVar (toRdrName id)) noSrcLoc +\end{code} + + +%************************************************************************ +%* * +\subsection[DeprecDecl]{Deprecations} +%* * +%************************************************************************ + +We use exported entities for things to deprecate. Cunning trick (hack?): +`IEModuleContents undefined' is used for module deprecation. + +\begin{code} +data DeprecDecl name = Deprecation (IE name) DeprecTxt SrcLoc + +type DeprecTxt = FAST_STRING -- reason/explanation for deprecation + +instance Outputable name => Outputable (DeprecDecl name) where + ppr (Deprecation (IEModuleContents _) txt _) + = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"] + ppr (Deprecation thing txt _) + = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 620f060bb0..fb4429dba0 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -24,6 +24,7 @@ import Type ( Type ) import Var ( TyVar, Id ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) +import BasicTypes ( Boxity, tupleParens ) import SrcLoc ( SrcLoc ) \end{code} @@ -107,7 +108,7 @@ data HsExpr id pat -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components - Bool -- boxed? + Boxity -- Record construction @@ -307,11 +308,8 @@ ppr_expr (ExplicitListOut ty exprs) = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))), ifNotPprForUser ((<>) space (parens (pprType ty))) ] -ppr_expr (ExplicitTuple exprs True) - = parens (sep (punctuate comma (map ppr_expr exprs))) - -ppr_expr (ExplicitTuple exprs False) - = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)") +ppr_expr (ExplicitTuple exprs boxity) + = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) ppr_expr (RecordCon con_id rbinds) = pp_rbinds (ppr con_id) rbinds diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 7800a025d5..5ee977726b 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -71,6 +71,13 @@ ieName (IEVar n) = n ieName (IEThingAbs n) = n ieName (IEThingWith n _) = n ieName (IEThingAll n) = n + +ieNames :: IE a -> [a] +ieNames (IEVar n ) = [n] +ieNames (IEThingAbs n ) = [n] +ieNames (IEThingAll n ) = [n] +ieNames (IEThingWith n ns) = n:ns +ieNames (IEModuleContents _ ) = [] \end{code} \begin{code} diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 94409c43f7..640c717148 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -13,7 +13,7 @@ module HsMatches where -- Friends import HsExpr ( HsExpr, Stmt(..) ) import HsBinds ( HsBinds(..), nullBinds ) -import HsTypes ( HsTyVar, HsType ) +import HsTypes ( HsTyVarBndr, HsType ) -- Others import Type ( Type ) @@ -44,7 +44,7 @@ patterns in each equation. \begin{code} data Match id pat = Match - [HsTyVar id] -- Tyvars wrt which this match is universally quantified + [HsTyVarBndr id] -- Tyvars wrt which this match is universally quantified -- emtpy after typechecking [pat] -- The patterns (Maybe (HsType id)) -- A type signature for the result of the match diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index b83d5022a2..6e4051ec83 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -21,7 +21,7 @@ module HsPat ( import HsBasic ( HsLit ) import HsExpr ( HsExpr ) import HsTypes ( HsType ) -import BasicTypes ( Fixity ) +import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: import Var ( Id, TyVar ) @@ -61,7 +61,7 @@ data InPat name | ListPatIn [InPat name] -- syntactic list -- must have >= 1 elements - | TuplePatIn [InPat name] Bool -- tuple (boxed?) + | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning @@ -78,7 +78,7 @@ data OutPat id [OutPat id] | TuplePat [OutPat id] -- tuple - Bool -- boxed? + Boxity -- UnitPat is TuplePat [] | ConPat DataCon @@ -165,10 +165,8 @@ pprInPat (ParPatIn pat) pprInPat (ListPatIn pats) = brackets (interpp'SP pats) -pprInPat (TuplePatIn pats False) - = text "(#" <> (interpp'SP pats) <> text "#)" -pprInPat (TuplePatIn pats True) - = parens (interpp'SP pats) +pprInPat (TuplePatIn pats boxity) + = tupleParens boxity (interpp'SP pats) pprInPat (NPlusKPatIn n k) = parens (hcat [ppr n, char '+', ppr k]) @@ -205,12 +203,8 @@ pprOutPat (ConPat name ty tyvars dicts pats) hsep [ppr p1, ppr name, ppr p2] _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] -pprOutPat (ListPat ty pats) - = brackets (interpp'SP pats) -pprOutPat (TuplePat pats boxed@True) - = parens (interpp'SP pats) -pprOutPat (TuplePat pats unboxed@False) - = text "(#" <> (interpp'SP pats) <> text "#)" +pprOutPat (ListPat ty pats) = brackets (interpp'SP pats) +pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats) pprOutPat (RecPat con ty tvs dicts rpats) = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 2536e8d07c..a795a2f1ae 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -5,71 +5,101 @@ \begin{code} module HsTypes ( - HsType(..), MonoUsageAnn(..), HsTyVar(..), - HsContext, HsClassAssertion, HsPred(..) + HsType(..), HsUsageAnn(..), HsTyVarBndr(..), + , HsContext, HsPred(..) + , HsTupCon(..), hsTupParens, mkHsTupCon, - , mkHsForAllTy, mkHsUsForAllTy + , mkHsForAllTy, mkHsUsForAllTy, mkHsDictTy, mkHsIParamTy , getTyVarName, replaceTyVarName - , pprParendHsType - , pprForAll, pprHsContext, pprHsClassAssertion, pprHsPred - , cmpHsType, cmpHsTypes, cmpHsContext, cmpHsPred + + -- Printing + , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr + + -- Equality over Hs things + , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, + , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsType, eq_hsContext, eqListBy + + -- Converting from Type to HsType + , toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs ) where #include "HsVersions.h" -import Type ( Kind, UsageAnn(..) ) -import PprType ( {- instance Outputable Kind -} ) +import Class ( FunDep ) +import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext, + getTyVar_maybe, splitFunTy_maybe, splitAppTy_maybe, + splitTyConApp_maybe, splitPredTy_maybe, + splitUsgTy, splitSigmaTy, unUsgTy, boxedTypeKind + ) +import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation +import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, tyConClass_maybe ) +import PrelInfo ( mkTupConRdrName ) +import RdrName ( RdrName ) +import Name ( toRdrName ) +import OccName ( NameSpace ) +import Var ( TyVar, tyVarKind ) +import PprType ( {- instance Outputable Kind -}, pprParendKind ) +import BasicTypes ( Arity, Boxity(..), tupleParens ) +import Unique ( hasKey, listTyConKey, Uniquable(..) ) +import Maybes ( maybeToBool ) +import FiniteMap import Outputable -import Util ( thenCmp, cmpList ) \end{code} This is the syntax for types as seen in type signatures. \begin{code} type HsContext name = [HsPred name] -type HsClassAssertion name = (name, [HsType name]) --- The type is usually a type variable, but it --- doesn't have to be when reading interface files -data HsPred name = - HsPClass name [HsType name] - | HsPIParam name (HsType name) + +data HsPred name = HsPClass name [HsType name] + | HsPIParam name (HsType name) data HsType name - = HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures - (HsContext name) - (HsType name) + = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures + (HsContext name) + (HsType name) - | MonoTyVar name -- Type variable + | HsTyVar name -- Type variable - | MonoTyApp (HsType name) + | HsAppTy (HsType name) (HsType name) - | MonoFunTy (HsType name) -- function type + | HsFunTy (HsType name) -- function type (HsType name) - | MonoListTy (HsType name) -- Element type - - | MonoTupleTy [HsType name] -- Element types (length gives arity) - Bool -- boxed? + | HsListTy (HsType name) -- Element type - | MonoIParamTy name (HsType name) + | HsTupleTy (HsTupCon name) + [HsType name] -- Element types (length gives arity) -- these next two are only used in interfaces - | MonoDictTy name -- Class - [HsType name] + | HsPredTy (HsPred name) - | MonoUsgTy (MonoUsageAnn name) + | HsUsgTy (HsUsageAnn name) (HsType name) - | MonoUsgForAllTy name + | HsUsgForAllTy name (HsType name) -data MonoUsageAnn name - = MonoUsOnce - | MonoUsMany - | MonoUsVar name +data HsUsageAnn name + = HsUsOnce + | HsUsMany + | HsUsVar name +----------------------- +data HsTupCon name = HsTupCon name Boxity + +instance Eq name => Eq (HsTupCon name) where + (HsTupCon _ b1) == (HsTupCon _ b2) = b1==b2 + +mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName +mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity (length args)) boxity + +hsTupParens :: HsTupCon name -> SDoc -> SDoc +hsTupParens (HsTupCon _ b) p = tupleParens b p + +----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: -- f :: forall a. ((Num a) => Int) @@ -87,10 +117,13 @@ mkHsForAllTy mtvs1 [] (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty -mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty) +mkHsUsForAllTy uvs ty = foldr (\ uv ty -> HsUsgForAllTy uv ty) ty uvs -data HsTyVar name +mkHsDictTy cls tys = HsPredTy (HsPClass cls tys) +mkHsIParamTy v ty = HsPredTy (HsPIParam v ty) + +data HsTyVarBndr name = UserTyVar name | IfaceTyVar name Kind -- *** NOTA BENE *** A "monotype" in a pragma can have @@ -100,7 +133,7 @@ data HsTyVar name getTyVarName (UserTyVar n) = n getTyVarName (IfaceTyVar n _) = n -replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2 +replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 replaceTyVarName (UserTyVar n) n' = UserTyVar n' replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \end{code} @@ -113,31 +146,30 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k %************************************************************************ \begin{code} - instance (Outputable name) => Outputable (HsType name) where ppr ty = pprHsType ty -instance (Outputable name) => Outputable (HsTyVar name) where +instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name) = ppr name - ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind] + ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind + +instance Outputable name => Outputable (HsPred name) where + ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys) + ppr (HsPIParam n ty) = hsep [{- char '?' <> -} ppr n, text "::", ppr ty] --- Better to see those for-alls --- pprForAll [] = empty -pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".") +pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc +pprHsTyVarBndr name kind | kind == boxedTypeKind = ppr name + | otherwise = hsep [ppr name, dcolon, pprParendKind kind] + +pprHsForAll [] [] = empty +pprHsForAll tvs cxt = ptext SLIT("__forall") <+> interppSP tvs <+> ppr_context cxt <+> ptext SLIT("=>") pprHsContext :: (Outputable name) => HsContext name -> SDoc -pprHsContext [] = empty -pprHsContext context = parens (hsep (punctuate comma (map pprHsPred context))) <+> ptext SLIT("=>") - -pprHsClassAssertion :: (Outputable name) => HsClassAssertion name -> SDoc -pprHsClassAssertion (clas, tys) - = ppr clas <+> hsep (map pprParendHsType tys) - -pprHsPred :: (Outputable name) => HsPred name -> SDoc -pprHsPred (HsPClass clas tys) - = ppr clas <+> hsep (map pprParendHsType tys) -pprHsPred (HsPIParam n ty) - = hsep [{- char '?' <> -} ppr n, text "::", ppr ty] +pprHsContext [] = empty +pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>") + +ppr_context [] = empty +ppr_context cxt = parens (interpp'SP cxt) \end{code} \begin{code} @@ -158,42 +190,35 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) = maybeParen (ctxt_prec >= pREC_FUN) $ - sep [pp_tvs, pprHsContext ctxt, pprHsType ty] + sep [pp_header, pprHsType ty] where - pp_tvs = case maybe_tvs of - Just tvs -> pprForAll tvs - Nothing -> text "{- implicit forall -}" + pp_header = case maybe_tvs of + Just tvs -> pprHsForAll tvs ctxt + Nothing -> pprHsContext ctxt -ppr_mono_ty ctxt_prec (MonoTyVar name) +ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name -ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2) +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = let p1 = ppr_mono_ty pREC_FUN ty1 p2 = ppr_mono_ty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) (sep [p1, (<>) (ptext SLIT("-> ")) p2]) -ppr_mono_ty ctxt_prec (MonoTupleTy tys True) - = parens (sep (punctuate comma (map ppr tys))) -ppr_mono_ty ctxt_prec (MonoTupleTy tys False) - = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)") +ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty ctxt_prec (MonoListTy ty) - = brackets (ppr_mono_ty pREC_TOP ty) - -ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty) +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen (ctxt_prec >= pREC_CON) (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) -ppr_mono_ty ctxt_prec (MonoIParamTy n ty) - = hsep [{- char '?' <> -} ppr n, text "::", ppr_mono_ty pREC_TOP ty] - -ppr_mono_ty ctxt_prec (MonoDictTy clas tys) - = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys) - -ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _) +ppr_mono_ty ctxt_prec (HsPredTy pred) = maybeParen (ctxt_prec >= pREC_FUN) $ + braces (ppr pred) + +ppr_mono_ty ctxt_prec ty@(HsUsgForAllTy _ _) + = sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"), ppr_mono_ty pREC_TOP sigma ] @@ -201,17 +226,83 @@ ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _) (uvars,sigma) = split [] ty pp_uvars = interppSP uvars - split uvs (MonoUsgForAllTy uv ty') = split (uv:uvs) ty' + split uvs (HsUsgForAllTy uv ty') = split (uv:uvs) ty' split uvs ty' = (reverse uvs,ty') -ppr_mono_ty ctxt_prec (MonoUsgTy u ty) +ppr_mono_ty ctxt_prec (HsUsgTy u ty) = maybeParen (ctxt_prec >= pREC_CON) $ ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty where pp_ua = case u of - MonoUsOnce -> ptext SLIT("-") - MonoUsMany -> ptext SLIT("!") - MonoUsVar uv -> ppr uv + HsUsOnce -> ptext SLIT("-") + HsUsMany -> ptext SLIT("!") + HsUsVar uv -> ppr uv +\end{code} + + +%************************************************************************ +%* * +\subsection{Converting from Type to HsType} +%* * +%************************************************************************ + +@toHsType@ converts from a Type to a HsType, making the latter look as +user-friendly as possible. Notably, it uses synonyms where possible, and +expresses overloaded functions using the '=>' context part of a HsForAllTy. + +\begin{code} +toHsTyVar :: TyVar -> HsTyVarBndr RdrName +toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv) + +toHsTyVars tvs = map toHsTyVar tvs + +toHsType :: Type -> HsType RdrName +toHsType ty = toHsType' (unUsgTy ty) + -- For now we just discard the usage +-- = case splitUsgTy ty of +-- (usg, tau) -> HsUsgTy (toHsUsg usg) (toHsType' tau) + +toHsType' :: Type -> HsType RdrName +-- Called after the usage is stripped off +-- This function knows the representation of types +toHsType' (TyVarTy tv) = HsTyVar (toRdrName tv) +toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) +toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) + +toHsType' (NoteTy (SynNote ty) _) = toHsType ty -- Use synonyms if possible!! +toHsType' (NoteTy _ ty) = toHsType ty + +toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * + | not saturated = generic_case + | isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys' + | tc `hasKey` listTyConKey = HsListTy (head tys') + | maybeToBool maybe_class = HsPredTy (HsPClass (toRdrName clas) tys') + | otherwise = generic_case + where + generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys' + maybe_class = tyConClass_maybe tc + Just clas = maybe_class + tys' = map toHsType tys + saturated = length tys == tyConArity tc + +toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of + (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs)) + (map toHsPred preds) + (toHsType tau) + + +toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys) +toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty) + +toHsContext :: ClassContext -> HsContext RdrName +toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt] + +toHsUsg UsOnce = HsUsOnce +toHsUsg UsMany = HsUsMany +toHsUsg (UsVar v) = HsUsVar (toRdrName v) + +toHsFDs :: [FunDep TyVar] -> [FunDep RdrName] +toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds] \end{code} @@ -221,97 +312,115 @@ ppr_mono_ty ctxt_prec (MonoUsgTy u ty) %* * %************************************************************************ +\begin{code} +instance Ord a => Eq (HsType a) where + -- The Ord is needed because we keep a + -- finite map of variables to variables + (==) a b = eq_hsType emptyEqHsEnv a b + +instance Ord a => Eq (HsPred a) where + (==) a b = eq_hsPred emptyEqHsEnv a b + +eqWithHsTyVars :: Ord name => + [HsTyVarBndr name] -> [HsTyVarBndr name] + -> (EqHsEnv name -> Bool) -> Bool +eqWithHsTyVars = eq_hsTyVars emptyEqHsEnv +\end{code} + +\begin{code} +type EqHsEnv n = FiniteMap n n +-- Tracks the mapping from L-variables to R-variables + +eq_hsVar :: Ord n => EqHsEnv n -> n -> n -> Bool +eq_hsVar env n1 n2 = case lookupFM env n1 of + Just n1 -> n1 == n2 + Nothing -> n1 == n2 + +extendEqHsEnv env n1 n2 + | n1 == n2 = env + | otherwise = addToFM env n1 n2 + +emptyEqHsEnv :: EqHsEnv n +emptyEqHsEnv = emptyFM +\end{code} + We do define a specialised equality for these \tr{*Type} types; used -in checking interfaces. Most any other use is likely to be {\em -wrong}, so be careful! +in checking interfaces. \begin{code} -cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering -cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering -cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering -cmpHsContext :: (a -> a -> Ordering) -> HsContext a -> HsContext a -> Ordering -cmpHsPred :: (a -> a -> Ordering) -> HsPred a -> HsPred a -> Ordering +------------------- +eq_hsTyVars env [] [] k = k env +eq_hsTyVars env (tv1:tvs1) (tv2:tvs2) k = eq_hsTyVar env tv1 tv2 $ \ env -> + eq_hsTyVars env tvs1 tvs2 k +eq_hsTyVars env _ _ _ = False + +eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2) +eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 == k2 && k (extendEqHsEnv env v1 v2) +eq_hsTyVar env _ _ _ = False + +eq_hsVars env [] [] k = k env +eq_hsVars env (v1:bs1) (v2:bs2) k = eq_hsVars (extendEqHsEnv env v1 v2) bs1 bs2 k +eq_hsVars env _ _ _ = False +\end{code} -cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 -cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 -cmpHsTyVar cmp (UserTyVar _) other = LT -cmpHsTyVar cmp other1 other2 = GT +\begin{code} +------------------- +eq_hsTypes env = eqListBy (eq_hsType env) -cmpHsTypes cmp [] [] = EQ -cmpHsTypes cmp [] tys2 = LT -cmpHsTypes cmp tys1 [] = GT -cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2 +------------------- +eq_hsType env (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) + = eq_tvs tvs1 tvs2 $ \env -> + eq_hsContext env c1 c2 && + eq_hsType env t1 t2 + where + eq_tvs Nothing (Just _) k = False + eq_tvs Nothing Nothing k = k env + eq_tvs (Just _) Nothing k = False + eq_tvs (Just tvs1) (Just tvs2) k = eq_hsTyVars env tvs1 tvs2 k -cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp` - cmpHsContext cmp c1 c2 `thenCmp` - cmpHsType cmp t1 t2 +eq_hsType env (HsTyVar n1) (HsTyVar n2) + = eq_hsVar env n1 n2 -cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2) - = cmp n1 n2 +eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) + = (c1 == c2) && eq_hsTypes env tys1 tys2 -cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2) - = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2 +eq_hsType env (HsListTy ty1) (HsListTy ty2) + = eq_hsType env ty1 ty2 -cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2) - = cmpHsType cmp ty1 ty2 +eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2) + = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2 -cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2) - = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2 +eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) + = eq_hsType env a1 a2 && eq_hsType env b1 b2 -cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) - = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2 +eq_hsType env (HsPredTy p1) (HsPredTy p2) + = eq_hsPred env p1 p2 -cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2) - = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 +eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2) + = eqUsg u1 u2 && eq_hsType env ty1 ty2 -cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2) - = cmpUsg cmp u1 u2 `thenCmp` cmpHsType cmp ty1 ty2 +eq_hsType env ty1 ty2 = False -cmpHsType cmp ty1 ty2 -- tags must be different - = let tag1 = tag ty1 - tag2 = tag ty2 - in - if tag1 _LT_ tag2 then LT else GT - where - tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) - tag (MonoTupleTy tys1 _) = ILIT(2) - tag (MonoListTy ty1) = ILIT(3) - tag (MonoTyApp tc1 tys1) = ILIT(4) - tag (MonoFunTy a1 b1) = ILIT(5) - tag (MonoDictTy c1 tys1) = ILIT(6) - tag (MonoUsgTy c1 ty1) = ILIT(7) - tag (MonoUsgForAllTy uv1 ty1) = ILIT(8) - tag (HsForAllTy _ _ _) = ILIT(9) ------------------- -cmpHsContext cmp a b - = cmpList (cmpHsPred cmp) a b - -cmpHsPred cmp (HsPClass c1 tys1) (HsPClass c2 tys2) - = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 -cmpHsPred cmp (HsPIParam n1 ty1) (HsPIParam n2 ty2) - = cmp n1 n2 `thenCmp` cmpHsType cmp ty1 ty2 -cmpHsPred cmp (HsPClass _ _) (HsPIParam _ _) = LT -cmpHsPred cmp _ _ = GT - -cmpUsg cmp MonoUsOnce MonoUsOnce = EQ -cmpUsg cmp MonoUsMany MonoUsMany = EQ -cmpUsg cmp (MonoUsVar u1) (MonoUsVar u2) = cmp u1 u2 - -cmpUsg cmp ua1 ua2 -- tags must be different - = let tag1 = tag ua1 - tag2 = tag ua2 - in - if tag1 _LT_ tag2 then LT else GT - where - tag MonoUsOnce = (ILIT(1) :: FAST_INT) - tag MonoUsMany = ILIT(2) - tag (MonoUsVar _) = ILIT(3) - --- Should be in Maybes, I guess -cmpMaybe cmp Nothing Nothing = EQ -cmpMaybe cmp Nothing (Just x) = LT -cmpMaybe cmp (Just x) Nothing = GT -cmpMaybe cmp (Just x) (Just y) = x `cmp` y +eq_hsContext env a b = eqListBy (eq_hsPred env) a b + +------------------- +eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2) + = c1 == c2 && eq_hsTypes env tys1 tys2 +eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2) + = n1 == n2 && eq_hsType env ty1 ty2 +eq_hsPred env _ _ = False + +------------------- +eqUsg HsUsOnce HsUsOnce = True +eqUsg HsUsMany HsUsMany = True +eqUsg (HsUsVar u1) (HsUsVar u2) = u1 == u2 +eqUsg _ _ = False + +------------------- +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy eq [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy eq xs ys = False \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index ca1b58d012..25d080ea68 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -137,6 +137,7 @@ module CmdLineOpts ( opt_ProduceExportCStubs, opt_ProduceExportHStubs, opt_ProduceHi, + opt_NoPruneTyDecls, opt_NoPruneDecls, opt_ReportCompile, opt_SourceUnchanged, @@ -453,6 +454,7 @@ opt_UF_DearOp = ( 4 :: Int) opt_ReportCompile = lookUp SLIT("-freport-compile") opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls") +opt_NoPruneTyDecls = lookUp SLIT("-fno-prune-tydecls") opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged") opt_Static = lookUp SLIT("-static") opt_Unregisterised = lookUp SLIT("-funregisterised") diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 18b538b168..6c64a5c41e 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -32,7 +32,7 @@ import CmdLineOpts import Maybes ( maybeToBool ) import ErrUtils ( doIfSet, dumpIfSet ) import Outputable -import IO +import IO ( IOMode(..), hClose, openFile ) \end{code} @@ -109,8 +109,8 @@ outputAsm flat_absC ncg_uniqs #else /* OMIT_NATIVE_CODEGEN */ - = do hPutStrLn stderr "This compiler was built without a native code generator" - hPutStrLn stderr "Use -fvia-C instead" + = pprPanic "This compiler was built without a native code generator" + (text "Use -fvia-C instead") #endif \end{code} diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 641b9f769b..771b5132c8 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -207,8 +207,9 @@ wORD64_SIZE = (WORD64_SIZE :: Int) iNT64_SIZE = (INT64_SIZE :: Int) \end{code} -The version of the interface file format we're -using: +The version of the interface file format we're using. It's propagated +here by a devious route from ghc/mk/version.mk. See comments +there for what it means. \begin{code} interfaceFileFormatVersion :: Int diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 4ffef76d06..beb70cba7d 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -20,9 +20,8 @@ import Lex ( PState(..), P, ParseResult(..) ) import SrcLoc ( mkSrcLoc ) import Rename ( renameModule ) -import RnMonad ( InterfaceDetails(..) ) -import MkIface ( startIface, ifaceDecls, endIface ) +import MkIface ( writeIface ) import TcModule ( TcResults(..), typecheckModule ) import Desugar ( deSugar ) import SimplCore ( core2core ) @@ -124,24 +123,18 @@ doIt (core_cmds, stg_cmds) reportCompile mod_name "Compilation NOT required!" >> return (); - Just (this_mod, rn_mod, iface_file_stuff@(InterfaceDetails _ _ _ deprecations), - rn_name_supply, imported_modules) -> + Just (this_mod, rn_mod, + old_iface, new_iface, + rn_name_supply, fixity_env, + imported_modules) -> -- Oh well, we've got to recompile for real - -------------------------- Start interface file ---------------- - -- Safely past renaming: we can start the interface file: - -- (the iface file is produced incrementally, as we have - -- the information that we need...; we use "iface<blah>") - -- "endIface" finishes the job. - startIface this_mod iface_file_stuff >>= \ if_handle -> - - -------------------------- Typechecking ---------------- show_pass "TypeCheck" >> _scc_ "TypeCheck" typecheckModule tc_uniqs rn_name_supply - iface_file_stuff rn_mod >>= \ maybe_tc_stuff -> + fixity_env rn_mod >>= \ maybe_tc_stuff -> case maybe_tc_stuff of { Nothing -> ghcExit 1; -- Type checker failed @@ -163,6 +156,12 @@ doIt (core_cmds, stg_cmds) tidyCorePgm tidy_uniqs this_mod simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) -> + coreBindsSize tidy_binds `seq` +-- TEMP: the above call zaps some space usage allocated by the +-- simplifier, which for reasons I don't understand, persists +-- thoroughout code generation + + -------------------------- Convert to STG code ------------------------------- show_pass "Core2Stg" >> @@ -183,16 +182,9 @@ doIt (core_cmds, stg_cmds) let final_ids = collectFinalStgBinders (map fst stg_binds2) in - coreBindsSize tidy_binds `seq` --- TEMP: the above call zaps some space usage allocated by the --- simplifier, which for reasons I don't understand, persists --- thoroughout code generation - - ifaceDecls if_handle local_tycons local_classes inst_info - final_ids tidy_binds tidy_orphan_rules deprecations >> - endIface if_handle >> - -- We are definitely done w/ interface-file stuff at this point: - -- (See comments near call to "startIface".) + writeIface this_mod old_iface new_iface + local_tycons local_classes inst_info + final_ids tidy_binds tidy_orphan_rules >> -------------------------- Code generation ------------------------------- @@ -331,8 +323,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData _ _ _ _ constrs derivs _ _) - = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) + data_info (TyData _ _ _ _ _ nconstrs derivs _ _) + = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 50ebde3837..7370529ffa 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -4,9 +4,7 @@ \section[MkIface]{Print an interface for a module} \begin{code} -module MkIface ( - startIface, endIface, ifaceDecls - ) where +module MkIface ( writeIface ) where #include "HsVersions.h" @@ -14,8 +12,12 @@ import IO ( Handle, hPutStr, openFile, hClose, hPutStrLn, IOMode(..) ) import HsSyn -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), - OccInfo, isLoopBreaker +import HsCore ( HsIdInfo(..), toUfExpr ) +import RdrHsSyn ( RdrNameRuleDecl ) +import HsPragmas ( DataPragmas(..), ClassPragmas(..) ) +import HsTypes ( toHsTyVars ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), + Version, bumpVersion, initialVersion, isLoopBreaker ) import RnMonad import RnEnv ( availName ) @@ -29,24 +31,25 @@ import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, import Var ( isId ) import VarSet import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inlinePragInfo, - arityInfo, ppArityInfo, arityLowerBound, - strictnessInfo, ppStrictnessInfo, isBottomingStrictness, - cafInfo, ppCafInfo, specInfo, - cprInfo, ppCprInfo, pprInlinePragInfo, +import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..), + CprInfo(..), CafInfo(..), + inlinePragInfo, arityInfo, arityLowerBound, + strictnessInfo, isBottomingStrictness, + cafInfo, specInfo, cprInfo, occInfo, isNeverInlinePrag, - workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..) + workerExists, workerInfo, WorkerInfo(..) ) -import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars ) +import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) import Module ( moduleString, pprModule, pprModuleName ) -import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule, +import RdrName ( RdrName ) +import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule, Name, NamedThing(..) ) import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, - tyConTheta, tyConTyVars, tyConDataCons + tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize ) import Class ( Class, classExtraBigSig ) import FieldLabel ( fieldLabelName, fieldLabelType ) @@ -56,7 +59,6 @@ import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, ) import PprType -import PprCore ( pprIfaceUnfolding, pprCoreRule ) import FunDeps ( pprFundeps ) import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) @@ -66,222 +68,311 @@ import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap ) import UniqFM ( lookupUFM, listToUFM ) import UniqSet ( uniqSetToList ) import Util ( sortLt, mapAccumL ) +import SrcLoc ( noSrcLoc ) import Bag import Outputable \end{code} -We have a function @startIface@ to open the output file and put -(something like) ``interface Foo'' in it. It gives back a handle -for subsequent additions to the interface file. -We then have one-function-per-block-of-interface-stuff, e.g., -@ifaceExportList@ produces the @__exports__@ section; it appends -to the handle provided by @startIface@. - -NOTE: ALWAYS remember that ghc-iface.lprl rewrites the interface file, -so you have to keep it in synch with the code below. Otherwise you'll -lose the happiest years of your life, believe me... -- SUP +%************************************************************************ +%* * +\subsection{Write a new interface file} +%* * +%************************************************************************ \begin{code} -startIface :: Module -> InterfaceDetails - -> IO (Maybe Handle) -- Nothing <=> don't do an interface +writeIface this_mod old_iface new_iface + local_tycons local_classes inst_info + final_ids tidy_binds tidy_orphan_rules + = case opt_ProduceHi of { + Nothing -> return () ; -- not producing any .hi file + + Just filename -> + + case checkIface old_iface full_new_iface of { + Nothing -> do { putStrLn "Interface file unchanged" ; + return () } ; -- No need to update .hi file + + Just final_iface -> + + do let mod_vers_unchanged = case old_iface of + Just iface -> pi_vers iface == pi_vers final_iface + Nothing -> False + if mod_vers_unchanged + then putStrLn "Module version unchanged, but usages differ; hence need new hi file" + else return () + + if_hdl <- openFile filename WriteMode + printForIface if_hdl (pprIface final_iface) + hClose if_hdl + }} + where + full_new_iface = completeIface new_iface local_tycons local_classes + inst_info final_ids tidy_binds + tidy_orphan_rules +\end{code} -ifaceDecls :: Maybe Handle - -> [TyCon] -> [Class] - -> Bag InstInfo - -> [Id] -- Ids used at code-gen time; they have better pragma info! - -> [CoreBind] -- In dependency order, later depend on earlier - -> [ProtoCoreRule] -- Rules - -> [Deprecation Name] - -> IO () -endIface :: Maybe Handle -> IO () -\end{code} +%************************************************************************ +%* * +\subsection{Checking if the new interface is up to date +%* * +%************************************************************************ \begin{code} -startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _) - = case opt_ProduceHi of - Nothing -> return Nothing ; -- not producing any .hi file - - Just fn -> do - if_hdl <- openFile fn WriteMode - hPutStr if_hdl ("__interface \"" ++ show opt_InPackage ++ "\" " ++ moduleString mod) - hPutStr if_hdl (' ' : orphan_indicator) - hPutStrLn if_hdl " where" - ifaceExports if_hdl avails - ifaceImports if_hdl import_usages - ifaceFixities if_hdl fixities - return (Just if_hdl) +checkIface :: Maybe ParsedIface -- The old interface, read from M.hi + -> ParsedIface -- The new interface; but with all version numbers = 1 + -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface + -- Just pi => Here is the new interface to write + -- with correct version numbers + +-- NB: the fixities, declarations, rules are all assumed +-- to be sorted by increasing order of hsDeclName, so that +-- we can compare for equality + +checkIface Nothing new_iface +-- No old interface, so definitely write a new one! + = Just new_iface + +checkIface (Just iface) new_iface + | no_output_change && no_usage_change + = Nothing + + | otherwise -- Add updated version numbers + = +{- pprTrace "checkIface" ( + vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change, + text "--------", + vcat (map ppr (pi_decls iface)), + text "--------", + vcat (map ppr (pi_decls new_iface)) + ]) $ +-} + Just (new_iface { pi_vers = new_mod_vers, + pi_fixity = (new_fixity_vers, new_fixities), + pi_rules = (new_rules_vers, new_rules), + pi_decls = final_decls + }) + where - orphan_indicator | has_orphans = " !" - | otherwise = "" + no_usage_change = pi_usages iface == pi_usages new_iface + + no_output_change = no_decl_changed && + new_fixity_vers == fixity_vers && + new_rules_vers == rules_vers && + no_export_change + + no_export_change = pi_exports iface == pi_exports new_iface + + new_mod_vers | no_output_change = mod_vers + | otherwise = bumpVersion mod_vers + + mod_vers = pi_vers iface + + (fixity_vers, fixities) = pi_fixity iface + (_, new_fixities) = pi_fixity new_iface + new_fixity_vers | fixities == new_fixities = fixity_vers + | otherwise = bumpVersion fixity_vers + + (rules_vers, rules) = pi_rules iface + (_, new_rules) = pi_rules new_iface + new_rules_vers | rules == new_rules = rules_vers + | otherwise = bumpVersion rules_vers + + (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface) + + -- Fill in the version number on the new declarations + -- by looking at the old declarations. + -- Set the flag if anything changes. + -- Assumes that the decls are sorted by hsDeclName + merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc) + merge_decls ok_so_far acc old [] = (False, reverse acc) + merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds + merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds) + = case d_name `compare` nd_name of + LT -> merge_decls False acc vds (nvd:nvds) + GT -> merge_decls False (nvd:acc) (vd:vds) nvds + EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds + | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds + where + d_name = hsDeclName d + nd_name = hsDeclName nd +\end{code} + + + +%************************************************************************ +%* * +\subsection{Printing the interface} +%* * +%************************************************************************ -endIface Nothing = return () -endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl +\begin{code} +pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan, + pi_usages = usages, pi_exports = exports, + pi_fixity = (fix_vers, fixities), + pi_insts = insts, pi_decls = decls, + pi_rules = (rule_vers, rules), pi_deprecs = deprecs }) + = vcat [ ptext SLIT("__interface") + <+> doubleQuotes (ptext opt_InPackage) + <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers + <+> (if orphan then char '!' else empty) + <+> int opt_HiVersion + <+> ptext SLIT("where") + , vcat (map pprExport exports) + , vcat (map pprUsage usages) + , pprFixities fixities + , vcat [ppr i <+> semi | i <- insts] + , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls] + , pprRules rules + , pprDeprecs deprecs + ] + where + ppr_vers v | v == initialVersion = empty + | otherwise = int v + pp_sub_vers + | fix_vers == initialVersion && rule_vers == initialVersion = empty + | otherwise = brackets (ppr fix_vers <+> ppr rule_vers) \end{code} +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C \begin{code} -ifaceDecls Nothing tycons classes inst_info final_ids simplified rules _ = return () -ifaceDecls (Just hdl) - tycons classes - inst_infos - final_ids - binds - orphan_rules -- Rules defined locally for an Id that is *not* defined locally - deprecations - | null_decls = return () - -- You could have a module with just (re-)exports/instances in it - | otherwise - = ifaceClasses hdl classes >> - ifaceInstances hdl inst_infos >>= \ inst_ids -> - ifaceTyCons hdl tycons >> - ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids) - final_ids binds >>= \ emitted_ids -> - ifaceRules hdl orphan_rules emitted_ids >> - ifaceDeprecations hdl deprecations +pprExport :: ExportItem -> SDoc +pprExport (mod, items) + = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi where - orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule - | ProtoCoreRule _ _ rule <- orphan_rules] - - null_decls = null binds && - null tycons && - null classes && - isEmptyBag inst_infos && - null orphan_rules && - null deprecations + upp_avail :: RdrAvailInfo -> SDoc + upp_avail (Avail name) = pprOccName name + upp_avail (AvailTC name []) = empty + upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns'] + where + bang | name `elem` ns = empty + | otherwise = char '|' + ns' = filter (/= name) ns + + upp_export [] = empty + upp_export names = braces (hsep (map pprOccName names)) \end{code} + \begin{code} -ifaceImports :: Handle -> VersionInfo Name -> IO () -ifaceImports if_hdl import_usages - = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) +pprUsage :: ImportVersion OccName -> SDoc +pprUsage (m, has_orphans, is_boot, whats_imported) + = hsep [ptext SLIT("import"), pprModuleName m, + pp_orphan, pp_boot, + upp_import_versions whats_imported + ] <> semi where - upp_uses (m, mv, has_orphans, is_boot, whats_imported) - = hsep [ptext SLIT("import"), pprModuleName m, - int mv, pp_orphan, pp_boot, - upp_import_versions whats_imported - ] <> semi - where - pp_orphan | has_orphans = ptext SLIT("!") - | otherwise = empty - pp_boot | is_boot = ptext SLIT("@") - | otherwise = empty + pp_orphan | has_orphans = char '!' + | otherwise = empty + pp_boot | is_boot = char '@' + | otherwise = empty -- Importing the whole module is indicated by an empty list - upp_import_versions Everything = empty - - -- For imported versions we do print the version number - upp_import_versions (Specifically nvs) - = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] - -{- SUP: What's this?? -ifaceModuleDeps if_hdl [] = return () -ifaceModuleDeps if_hdl mod_deps - = let - lines = map ppr_mod_dep mod_deps - ppr_mod_dep (mod, contains_orphans) - | contains_orphans = pprModuleName mod <+> ptext SLIT("!") - | otherwise = pprModuleName mod - in - printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >> - hPutStr if_hdl "\n" --} + upp_import_versions NothingAtAll = empty + upp_import_versions (Everything v) = dcolon <+> int v + upp_import_versions (Specifically vm vf vr nvs) + = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ] +\end{code} -ifaceExports :: Handle -> Avails -> IO () -ifaceExports if_hdl [] = return () -ifaceExports if_hdl avails - = hPutCol if_hdl do_one_module (fmToList export_fm) - where - -- Sort them into groups by module - export_fm :: FiniteMap Module [AvailInfo] - export_fm = foldr insert emptyFM avails - - insert avail efm = addToFM_C (++) efm mod [avail] - where - mod = nameModule (availName avail) - - -- Print one module's worth of stuff - do_one_module :: (Module, [AvailInfo]) -> SDoc - do_one_module (mod_name, avails@(avail1:_)) - = ptext SLIT("__export ") <> - hsep [pprModule mod_name, - hsep (map upp_avail (sortLt lt_avail avails)) - ] <> semi - -ifaceFixities :: Handle -> Fixities -> IO () -ifaceFixities if_hdl [] = return () -ifaceFixities if_hdl fixities - = hPutCol if_hdl upp_fixity fixities - -ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO () -ifaceRules if_hdl rules emitted - | opt_OmitInterfacePragmas -- Don't emit rules if we are suppressing - -- interface pragmas - || (null orphan_rule_pretties && null local_id_pretties) - = return () - | otherwise - = printForIface if_hdl (vcat [ - ptext SLIT("{-## __R"), - vcat orphan_rule_pretties, - vcat local_id_pretties, - ptext SLIT("##-}") - ]) - where - orphan_rule_pretties = [ pprCoreRule (Just fn) rule - | ProtoCoreRule _ fn rule <- rules - ] - local_id_pretties = [ pprCoreRule (Just fn) rule - | fn <- varSetElems emitted, - rule <- rulesRules (idSpecialisation fn), - all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) - -- Spit out a rule only if all its lhs free vars are emitted - -- This is a good reason not to do it when we emit the Id itself - ] - -ifaceDeprecations :: Handle -> [Deprecation Name] -> IO () -ifaceDeprecations if_hdl [] = return () -ifaceDeprecations if_hdl deprecations - = printForIface if_hdl (vcat [ - ptext SLIT("{-## __D"), - vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ], - ptext SLIT("##-}") - ]) + +\begin{code} +pprFixities [] = empty +pprFixities fixes = hsep (map ppr fixes) <> semi + +pprRules [] = empty +pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")] + +pprDeprecs [] = empty +pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")] + where + guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi + | Deprecation ie txt _ <- deps ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Completing the new interface} +%* * +%************************************************************************ + +\begin{code} +completeIface new_iface local_tycons local_classes + inst_info final_ids tidy_binds + tidy_orphan_rules + = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls], + pi_insts = sortLt lt_inst_decl inst_dcls, + pi_rules = (initialVersion, rule_dcls) + } where - pprIE (IEVar n ) = ppr n - pprIE (IEThingAbs n ) = ppr n - pprIE (IEThingAll n ) = hcat [ppr n, text "(..)"] - pprIE (IEThingWith n ns) = ppr n <> parens (hcat (punctuate comma (map ppr ns))) - pprIE (IEModuleContents _ ) = empty + all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls + (inst_dcls, inst_ids) = ifaceInstances inst_info + cls_dcls = map ifaceClass local_classes + ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons) + + (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids) + final_ids tidy_binds + + rule_dcls | opt_OmitInterfacePragmas = [] + | otherwise = ifaceRules tidy_orphan_rules emitted_ids + + orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule + | ProtoCoreRule _ _ rule <- tidy_orphan_rules] + +lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _) + = dfun_id1 < dfun_id2 + -- The dfuns are assigned names df1, df2, etc, + -- in order of original textual + -- occurrence, and this makes as good a sort order as any + +lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2 \end{code} + %************************************************************************ %* * -\subsection{Instance declarations} +\subsection{Completion stuff} %* * %************************************************************************ +\begin{code} +ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl] +ifaceRules rules emitted + = orphan_rules ++ local_rules + where + orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ] + local_rules = [ toHsRule fn rule + | fn <- varSetElems emitted, + rule <- rulesRules (idSpecialisation fn), + not (isBuiltinRule rule), + -- We can't print builtin rules in interface files + -- Since they are built in, an importing module + -- will have access to them anyway + all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) + -- Spit out a rule only if all its lhs free vars are emitted + -- This is a good reason not to do it when we emit the Id itself + ] +\end{code} \begin{code} -ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns -ifaceInstances if_hdl inst_infos - | null togo_insts = return emptyVarSet - | otherwise = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >> - return needed_ids - where +ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet) + -- The IdSet is the needed dfuns + +ifaceInstances inst_infos + = (decls, needed_ids) + where + decls = map to_decl togo_insts togo_insts = filter is_togo_inst (bagToList inst_infos) needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts] is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id ------- - lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _) - (InstInfo _ _ _ _ dfun_id2 _ _ _) - = getOccName dfun_id1 < getOccName dfun_id2 - -- The dfuns are assigned names df1, df2, etc, in order of original textual - -- occurrence, and this makes as good a sort order as any - - ------- - pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _) + to_decl (InstInfo clas tvs tys theta dfun_id _ _ _) = let -- The deNoteType is very important. It removes all type -- synonyms from the instance type in interface files. @@ -294,88 +385,217 @@ ifaceInstances if_hdl inst_infos -- that mentioned T but not Tibble. forall_ty = mkSigmaTy tvs (classesToPreds theta) (deNoteType (mkDictTy clas tys)) - renumbered_ty = tidyTopType forall_ty + tidy_ty = tidyTopType forall_ty in - hcat [ptext SLIT("instance "), pprType renumbered_ty, - ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] + InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc +\end{code} + +\begin{code} +ifaceTyCon :: TyCon -> RdrNameHsDecl +ifaceTyCon tycon + | isSynTyCon tycon + = TyClD (TySynonym (toRdrName tycon) + (toHsTyVars tyvars) (toHsType ty) + noSrcLoc) + where + (tyvars, ty) = getSynTyConDefn tycon + +ifaceTyCon tycon + | isAlgTyCon tycon + = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon)) + (toRdrName tycon) + (toHsTyVars tyvars) + (map ifaceConDecl (tyConDataCons tycon)) + (tyConFamilySize tycon) + Nothing NoDataPragmas noSrcLoc) + where + tyvars = tyConTyVars tycon + new_or_data | isNewTyCon tycon = NewType + | otherwise = DataType + + ifaceConDecl data_con + = ConDecl (toRdrName data_con) (error "ifaceConDecl") + (toHsTyVars ex_tyvars) + (toHsContext ex_theta) + details noSrcLoc + where + (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con + field_labels = dataConFieldLabels data_con + strict_marks = dataConStrictMarks data_con + details + | null field_labels + = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) + VanillaCon (zipWith mk_bang_ty strict_marks arg_tys) + + | otherwise + = RecCon (zipWith mk_field strict_marks field_labels) + + mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty) + mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty) + mk_bang_ty MarkedStrict ty = Banged (toHsType ty) + + mk_field strict_mark field_label + = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label)) + +ifaceTyCon tycon + = pprPanic "pprIfaceTyDecl" (ppr tycon) + +ifaceClass clas + = TyClD (ClassDecl (toHsContext sc_theta) + (toRdrName clas) + (toHsTyVars clas_tyvars) + (toHsFDs clas_fds) + (map toClassOpSig op_stuff) + EmptyMonoBinds NoClassPragmas + bogus bogus bogus [] noSrcLoc + ) + where + bogus = error "ifaceClass" + (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + + toClassOpSig (sel_id, dm_id, explicit_dm) + = ASSERT( sel_tyvars == clas_tyvars) + ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc + where + (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) \end{code} %************************************************************************ %* * -\subsection{Printing values} +\subsection{Value bindings} %* * %************************************************************************ \begin{code} -ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added - -- by the STG passes. Sigh +ifaceBinds :: IdSet -- These Ids are needed already + -> [Id] -- Ids used at code-gen time; they have better pragma info! + -> [CoreBind] -- In dependency order, later depend on earlier + -> (Bag RdrNameHsDecl, IdSet) -- Set of Ids actually spat out + +ifaceBinds needed_ids final_ids binds + = go needed_ids (reverse binds) emptyBag emptyVarSet + -- Reverse so that later things will + -- provoke earlier ones to be emitted + where + final_id_map = listToUFM [(id,id) | id <- final_ids] + get_idinfo id = case lookupUFM final_id_map id of + Just id' -> idInfo id' + Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ + idInfo id - -> IdSet -- Set of Ids that are needed by earlier interface - -- file emissions. If the Id isn't in this set, and isn't - -- exported, there's no need to emit anything - -> Bool -- True <=> recursive, so don't print unfolding - -> Id - -> CoreExpr -- The Id's right hand side - -> Maybe (SDoc, IdSet) -- The emitted stuff, plus any *extra* needed Ids + go needed [] decls emitted + | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" + (sep (map ppr (varSetElems needed))) + (decls, emitted) + | otherwise = (decls, emitted) + + go needed (NonRec id rhs : binds) decls emitted + = case ifaceId get_idinfo needed False id rhs of + Nothing -> go needed binds decls emitted + Just (decl, extras) -> let + needed' = (needed `unionVarSet` extras) `delVarSet` id + -- 'extras' can include the Id itself via a rule + emitted' = emitted `extendVarSet` id + in + go needed' binds (decl `consBag` decls) emitted' + + -- Recursive groups are a bit more of a pain. We may only need one to + -- start with, but it may call out the next one, and so on. So we + -- have to look for a fixed point. + go needed (Rec pairs : binds) decls emitted + = go needed' binds decls' emitted' + where + (new_decls, new_emitted, extras) = go_rec needed pairs + decls' = new_decls `unionBags` decls + needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) + emitted' = emitted `unionVarSet` new_emitted + + go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet) + go_rec needed pairs + | null decls = (emptyBag, emptyVarSet, emptyVarSet) + | otherwise = (more_decls `unionBags` listToBag decls, + more_emitted `unionVarSet` mkVarSet emitted, + more_extras `unionVarSet` extras) + where + maybes = map do_one pairs + emitted = [id | ((id,_), Just _) <- pairs `zip` maybes] + reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes] + (decls, extras_s) = unzip (catMaybes maybes) + extras = unionVarSets extras_s + (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs + + do_one (id,rhs) = ifaceId get_idinfo needed True id rhs +\end{code} + + +\begin{code} +ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added + -- by the STG passes. Sigh + + -> IdSet -- Set of Ids that are needed by earlier interface + -- file emissions. If the Id isn't in this set, and isn't + -- exported, there's no need to emit anything + -> Bool -- True <=> recursive, so don't print unfolding + -> Id + -> CoreExpr -- The Id's right hand side + -> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids ifaceId get_idinfo needed_ids is_rec id rhs | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] - (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted + (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs = ASSERT2( arity_matches_strictness, ppr id ) - Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids) + Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc), + new_needed_ids) where + id_type = idType id core_idinfo = idInfo id stg_idinfo = get_idinfo id - ty_pretty = pprType (idType id) - sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty] - - prag_pretty - | opt_OmitInterfacePragmas = empty - | otherwise = hsep [ptext SLIT("{-##"), - arity_pretty, - caf_pretty, - cpr_pretty, - strict_pretty, - wrkr_pretty, - unfold_pretty, - ptext SLIT("##-}")] + hs_idinfo | opt_OmitInterfacePragmas = [] + | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ + strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo ------------ Arity -------------- - arity_info = arityInfo stg_idinfo - arity_pretty = ppArityInfo arity_info + arity_info = arityInfo stg_idinfo + arity_hsinfo = case arityInfo stg_idinfo of + a@(ArityExactly n) -> [HsArity a] + other -> [] ------------ Caf Info -------------- - caf_pretty = ppCafInfo (cafInfo stg_idinfo) + caf_hsinfo = case cafInfo stg_idinfo of + NoCafRefs -> [HsNoCafRefs] + otherwise -> [] ------------ CPR Info -------------- - cpr_pretty = ppCprInfo (cprInfo core_idinfo) + cpr_hsinfo = case cprInfo core_idinfo of + ReturnsCPR -> [HsCprInfo] + NoCPRInfo -> [] ------------ Strictness -------------- strict_info = strictnessInfo core_idinfo bottoming_fn = isBottomingStrictness strict_info - strict_pretty = ppStrictnessInfo strict_info + strict_hsinfo = case strict_info of + NoStrictnessInfo -> [] + info -> [HsStrictness info] + ------------ Worker -------------- work_info = workerInfo core_idinfo has_worker = workerExists work_info - wrkr_pretty = ppWorkerInfo work_info - HasWorker work_id wrap_arity = work_info - - - ------------ Occ info -------------- - loop_breaker = isLoopBreaker (occInfo core_idinfo) + wrkr_hsinfo = case work_info of + HasWorker work_id _ -> [HsWorker (toRdrName work_id)] + other -> [] ------------ Unfolding -------------- inline_pragma = inlinePragInfo core_idinfo dont_inline = isNeverInlinePrag inline_pragma - unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs - | otherwise = empty + unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)] + | otherwise = [] show_unfold = not has_worker && -- Not unnecessary not bottoming_fn && -- Not necessary @@ -389,16 +609,20 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Specialisations -------------- spec_info = specInfo core_idinfo + ------------ Occ info -------------- + loop_breaker = isLoopBreaker (occInfo core_idinfo) + ------------ Extra free Ids -------------- new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet | otherwise = worker_ids `unionVarSet` unfold_ids `unionVarSet` spec_ids - worker_ids | has_worker && interestingId work_id = unitVarSet work_id + worker_ids = case work_info of + HasWorker work_id _ | interestingId work_id -> unitVarSet work_id -- Conceivably, the worker might come from -- another module - | otherwise = emptyVarSet + other -> emptyVarSet spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info) @@ -410,289 +634,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Sanity checking -------------- -- The arity of a wrapper function should match its strictness, -- or else an importing module will get very confused indeed. - arity_matches_strictness = not has_worker || - wrap_arity == arityLowerBound arity_info + arity_matches_strictness + = case work_info of + HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info + other -> True interestingId id = isId id && isLocallyDefined id && not (omitIfaceSigForId id) \end{code} -\begin{code} -ifaceBinds :: Handle - -> IdSet -- These Ids are needed already - -> [Id] -- Ids used at code-gen time; they have better pragma info! - -> [CoreBind] -- In dependency order, later depend on earlier - -> IO IdSet -- Set of Ids actually spat out - -ifaceBinds hdl needed_ids final_ids binds - = mapIO (printForIface hdl) (bagToList pretties) >> - hPutStr hdl "\n" >> - return emitted - where - final_id_map = listToUFM [(id,id) | id <- final_ids] - get_idinfo id = case lookupUFM final_id_map id of - Just id' -> idInfo id' - Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ - idInfo id - - (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet - -- Reverse so that later things will - -- provoke earlier ones to be emitted - go needed [] pretties emitted - | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" - (sep (map ppr (varSetElems needed))) - (pretties, emitted) - | otherwise = (pretties, emitted) - - go needed (NonRec id rhs : binds) pretties emitted - = case ifaceId get_idinfo needed False id rhs of - Nothing -> go needed binds pretties emitted - Just (pretty, extras) -> let - needed' = (needed `unionVarSet` extras) `delVarSet` id - -- 'extras' can include the Id itself via a rule - emitted' = emitted `extendVarSet` id - in - go needed' binds (pretty `consBag` pretties) emitted' - - -- Recursive groups are a bit more of a pain. We may only need one to - -- start with, but it may call out the next one, and so on. So we - -- have to look for a fixed point. - go needed (Rec pairs : binds) pretties emitted - = go needed' binds pretties' emitted' - where - (new_pretties, new_emitted, extras) = go_rec needed pairs - pretties' = new_pretties `unionBags` pretties - needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) - emitted' = emitted `unionVarSet` new_emitted - - go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet) - go_rec needed pairs - | null pretties = (emptyBag, emptyVarSet, emptyVarSet) - | otherwise = (more_pretties `unionBags` listToBag pretties, - more_emitted `unionVarSet` mkVarSet emitted, - more_extras `unionVarSet` extras) - where - maybes = map do_one pairs - emitted = [id | ((id,_), Just _) <- pairs `zip` maybes] - reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes] - (pretties, extras_s) = unzip (catMaybes maybes) - extras = unionVarSets extras_s - (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs - - do_one (id,rhs) = ifaceId get_idinfo needed True id rhs -\end{code} - - -%************************************************************************ -%* * -\subsection{Random small things} -%* * -%************************************************************************ - -\begin{code} -ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons)) -ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes)) - -for_iface_name name = isLocallyDefined name && - not (isWiredInName name) - -upp_tycon tycon = ifaceTyCon tycon -upp_class clas = ifaceClass clas -\end{code} - - -\begin{code} -ifaceTyCon :: TyCon -> SDoc -ifaceTyCon tycon - | isSynTyCon tycon - = hsep [ ptext SLIT("type"), - ppr (getName tycon), - pprTyVarBndrs tyvars, - ptext SLIT("="), - ppr ty, - semi - ] - where - (tyvars, ty) = getSynTyConDefn tycon - -ifaceTyCon tycon - | isAlgTyCon tycon - = hsep [ ptext keyword, - ppr_decl_class_context (tyConTheta tycon), - ppr (getName tycon), - pprTyVarBndrs (tyConTyVars tycon), - ptext SLIT("="), - hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))), - semi - ] - where - keyword | isNewTyCon tycon = SLIT("newtype") - | otherwise = SLIT("data") - - tyvars = tyConTyVars tycon - - ppr_con data_con - | null field_labels - = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - hsep [ ppr_ex ex_tyvars ex_theta, - ppr name, - hsep (map ppr_arg_ty (strict_marks `zip` arg_tys)) - ] - - | otherwise - = hsep [ ppr_ex ex_tyvars ex_theta, - ppr name, - braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) - ] - where - (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con - field_labels = dataConFieldLabels data_con - strict_marks = dataConStrictMarks data_con - name = getName data_con - - ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty - ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs) - <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>") - - ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty - - ppr_strict_mark NotMarkedStrict = empty - ppr_strict_mark (MarkedUnboxed _ _) = ptext SLIT("! ! ") - ppr_strict_mark MarkedStrict = ptext SLIT("! ") - - ppr_field (strict_mark, field_label) - = hsep [ ppr (fieldLabelName field_label), - dcolon, - ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label) - ] - -ifaceTyCon tycon - = pprPanic "pprIfaceTyDecl" (ppr tycon) - -ifaceClass clas - = hsep [ptext SLIT("class"), - ppr_decl_class_context sc_theta, - ppr clas, -- Print the name - pprTyVarBndrs clas_tyvars, - pprFundeps clas_fds, - pp_ops, - semi - ] - where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - - pp_ops | null op_stuff = empty - | otherwise = hsep [ptext SLIT("where"), - braces (hsep (punctuate semi (map ppr_classop op_stuff))) - ] - - ppr_classop (sel_id, dm_id, explicit_dm) - = ASSERT( sel_tyvars == clas_tyvars) - hsep [ppr (getOccName sel_id), - if explicit_dm then equals else empty, - dcolon, - ppr op_ty - ] - where - (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) - -ppr_decl_context :: ThetaType -> SDoc -ppr_decl_context [] = empty -ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>") - -ppr_decl_class_context :: ClassContext -> SDoc -ppr_decl_class_context [] = empty -ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>") - -pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files -pprIfaceTheta [] = empty -pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta])) - --- ZZ - not sure who uses this - i.e. whether IParams really show up or not --- (it's not used to print normal value signatures) -pprIfacePred :: PredType -> SDoc -pprIfacePred (Class clas tys) = pprConstraint clas tys -pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty - -pprIfaceClasses :: ClassContext -> SDoc -pprIfaceClasses [] = empty -pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) -\end{code} - -%************************************************************************ -%* * -\subsection{Random small things} -%* * -%************************************************************************ - -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C - -\begin{code} -upp_avail :: AvailInfo -> SDoc -upp_avail (Avail name) = pprOccName (getOccName name) -upp_avail (AvailTC name []) = empty -upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns'] - where - bang | name `elem` ns = empty - | otherwise = char '|' - ns' = filter (/= name) ns - -upp_export :: [Name] -> SDoc -upp_export [] = empty -upp_export names = braces (hsep (map (pprOccName . getOccName) names)) - -upp_fixity :: (Name, Fixity) -> SDoc -upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi] - -- Dummy version number! - -ppr_unqual_name :: NamedThing a => a -> SDoc -- Just its occurrence name -ppr_unqual_name name = pprOccName (getOccName name) -\end{code} - - -%************************************************************************ -%* * -\subsection{Comparisons} -%* * -%************************************************************************ - - -The various sorts above simply prevent unnecessary "wobbling" when -things change that don't have to. We therefore compare lexically, not -by unique - -\begin{code} -lt_avail :: AvailInfo -> AvailInfo -> Bool - -a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 - -lt_name :: Name -> Name -> Bool -n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2 - -lt_lexical :: NamedThing a => a -> a -> Bool -lt_lexical a1 a2 = getName a1 `lt_name` getName a2 - -lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool -lt_imp_vers (m1,_,_,_,_) (m2,_,_,_,_) = m1 < m2 - -sort_versions vs = sortLt lt_vers vs - -lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool -lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2 -\end{code} - - -\begin{code} -hPutCol :: Handle - -> (a -> SDoc) - -> [a] - -> IO () -hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs - -mapIO :: (a -> IO b) -> [a] -> IO () -mapIO f [] = return () -mapIO f (x:xs) = f x >> mapIO f xs -\end{code} diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 0a247e0d03..4283c328dc 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -38,11 +38,11 @@ import List ( isSuffixOf ) import IdInfo ( InlinePragInfo(..), CprInfo(..) ) import Name ( isLowerISO, isUpperISO ) -import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) +import PrelNames ( mkTupNameStr ) import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck ) import Demand ( Demand(..) {- instance Read -} ) import UniqFM ( UniqFM, listToUFM, lookupUFM) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( NewOrData(..), Boxity(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine, replaceSrcLine, mkSrcLoc ) @@ -1018,7 +1018,7 @@ lex_tuple cont mod buf back_off = go n buf = case currentChar# buf of ','# -> go (n+1) (stepOn buf) - ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf) + ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf) _ -> back_off lex_ubx_tuple cont mod buf back_off = @@ -1028,7 +1028,7 @@ lex_ubx_tuple cont mod buf back_off = case currentChar# buf of ','# -> go (n+1) (stepOn buf) '#'# -> case lookAhead# buf 1# of - ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n))) + ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n))) (stepOnBy# buf 2#) _ -> back_off _ -> back_off diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 93aa715702..3e7cafe184 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -18,7 +18,6 @@ module ParseUtil ( , checkPrec -- String -> P String , checkContext -- HsType -> P HsContext , checkInstType -- HsType -> P HsType - , checkAssertion -- HsType -> P HsAsst , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) , checkPattern -- HsExp -> P HsPat @@ -54,11 +53,12 @@ import SrcLoc import RdrHsSyn import RdrName import CallConv -import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr ) +import PrelNames ( pRELUDE_Name, mkTupNameStr ) import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString ) import CmdLineOpts ( opt_NoImplicitPrelude ) import StringBuffer ( lexemeToString ) import FastString ( unpackFS ) +import BasicTypes ( Boxity(..) ) import ErrUtils import UniqFM ( UniqFM, listToUFM, lookupUFM ) import Outputable @@ -86,9 +86,9 @@ splitForConApp :: RdrNameHsType -> [RdrNameBangType] splitForConApp t ts = split t ts where - split (MonoTyApp t u) ts = split t (Unbanged u : ts) + split (HsAppTy t u) ts = split t (Unbanged u : ts) - split (MonoTyVar t) ts = returnP (con, ts) + split (HsTyVar t) ts = returnP (con, ts) where t_occ = rdrNameOcc t con = setRdrNameOcc t (setOccNameSpace t_occ dataName) @@ -117,17 +117,17 @@ checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of HsForAllTy tvs ctxt ty -> - checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy tvs ctxt (MonoDictTy c ts)) + checkDictTy ty [] `thenP` \ dict_ty -> + returnP (HsForAllTy tvs ctxt dict_ty) - ty -> checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy Nothing [] (MonoDictTy c ts)) + ty -> checkDictTy ty [] `thenP` \ dict_ty-> + returnP (HsForAllTy Nothing [] dict_ty) checkContext :: RdrNameHsType -> P RdrNameContext -checkContext (MonoTupleTy ts True) +checkContext (HsTupleTy _ ts) = mapP (\t -> checkPred t []) ts `thenP` \ps -> returnP ps -checkContext (MonoTyVar t) -- empty contexts are allowed +checkContext (HsTyVar t) -- empty contexts are allowed | t == unitTyCon_RDR = returnP [] checkContext t = checkPred t [] `thenP` \p -> @@ -135,18 +135,17 @@ checkContext t checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName) -checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) +checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) = returnP (HsPClass t args) -checkPred (MonoTyApp l r) args = checkPred l (r:args) -checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty) +checkPred (HsAppTy l r) args = checkPred l (r:args) +checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty) checkPred _ _ = parseError "Illegal class assertion" -checkAssertion :: RdrNameHsType -> [RdrNameHsType] - -> P (HsClassAssertion RdrName) -checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (t,args) -checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args) -checkAssertion _ _ = parseError "Illegal class assertion" +checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType +checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (mkHsDictTy t args) +checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) +checkDictTy _ _ = parseError "Illegal class assertion" checkDataHeader :: RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) @@ -158,9 +157,9 @@ checkDataHeader t = returnP ([],c,map UserTyVar ts) checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) -checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a +checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a = checkSimple l (a:xs) -checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) +checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration" --------------------------------------------------------------------------- @@ -431,25 +430,25 @@ funTyCon_RDR | otherwise = mkPreludeQual tcName pRELUDE_Name funName tupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity)) | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr arity)) + (snd (mkTupNameStr Boxed arity)) tupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity)) | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr arity)) + (snd (mkTupNameStr Boxed arity)) ubxTupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity)) | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) + (snd (mkTupNameStr Unboxed arity)) ubxTupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity)) | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) + (snd (mkTupNameStr Unboxed arity)) unitName = SLIT("()") funName = SLIT("(->)") diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index d5521bfdf0..51bd67a901 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $ +$Id: Parser.y,v 1.31 2000/05/25 12:41:17 simonpj Exp $ Haskell grammar. @@ -13,18 +13,19 @@ module Parser ( parse ) where import HsSyn import HsPragmas +import HsTypes ( mkHsTupCon ) import RdrHsSyn import Lex import ParseUtil import RdrName -import PrelMods ( mAIN_Name ) -import OccName ( varName, ipName, dataName, tcClsName, tvName ) +import PrelInfo ( mAIN_Name ) +import OccName ( varName, ipName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CallConv import CmdLineOpts ( opt_SccProfilingOn ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) ) import Panic import GlaExts @@ -332,13 +333,13 @@ topdecl :: { RdrBinding } | srcloc 'data' ctype '=' constrs deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (TyData DataType cs c ts (reverse $5) $6 + (TyData DataType cs c ts (reverse $5) (length $5) $6 NoDataPragmas $1))) } | srcloc 'newtype' ctype '=' newconstr deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (TyData NewType cs c ts [$5] $6 + (TyData NewType cs c ts [$5] 1 $6 NoDataPragmas $1))) } | srcloc 'class' ctype fds where @@ -372,7 +373,9 @@ topdecl :: { RdrBinding } { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5) defaultCallConv $1)) } - | decl { $1 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# RULES' rules '#-}' { $2 } + | decl { $1 } decls :: { [RdrBinding] } : decls ';' decl { $3 : $1 } @@ -390,8 +393,6 @@ decl :: { RdrBinding } (map (\t -> RdrSig (SpecSig $3 t $2)) $5) } | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' { RdrSig (SpecInstSig $4 $2) } - | '{-# RULES' rules '#-}' { $2 } - | '{-# DEPRECATED' deprecations '#-}' { $2 } opt_phase :: { Maybe Int } : INTEGER { Just (fromInteger $1) } @@ -428,7 +429,7 @@ rules :: { RdrBinding } rule :: { RdrBinding } : STRING rule_forall fexp '=' srcloc exp - { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) } + { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) } rule_forall :: { [RdrNameRuleBndr] } : 'forall' rule_var_list '.' { $2 } @@ -454,7 +455,8 @@ deprecations :: { RdrBinding } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { RdrBinding } : srcloc exportlist STRING - { foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] } + { foldr RdrAndBindings RdrNullBind + [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } ----------------------------------------------------------------------------- -- Foreign import/export @@ -508,20 +510,20 @@ ctype :: { RdrNameHsType } | type { $1 } type :: { RdrNameHsType } - : btype '->' type { MonoFunTy $1 $3 } - | ipvar '::' type { MonoIParamTy $1 $3 } + : btype '->' type { HsFunTy $1 $3 } + | ipvar '::' type { mkHsIParamTy $1 $3 } | btype { $1 } btype :: { RdrNameHsType } - : btype atype { MonoTyApp $1 $2 } + : btype atype { HsAppTy $1 $2 } | atype { $1 } atype :: { RdrNameHsType } - : gtycon { MonoTyVar $1 } - | tyvar { MonoTyVar $1 } - | '(' type ',' types ')' { MonoTupleTy ($2 : reverse $4) True } - | '(#' types '#)' { MonoTupleTy (reverse $2) False } - | '[' type ']' { MonoListTy $2 } + : gtycon { HsTyVar $1 } + | tyvar { HsTyVar $1 } + | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) } + | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) } + | '[' type ']' { HsListTy $2 } | '(' ctype ')' { $2 } gtycon :: { RdrName } @@ -737,8 +739,8 @@ aexp1 :: { RdrNameHsExpr } | gcon { HsVar $1 } | literal { HsLit $1 } | '(' exp ')' { HsPar $2 } - | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) True } - | '(#' texps '#)' { ExplicitTuple (reverse $2) False } + | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} + | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } | '[' list ']' { $2 } | '(' infixexp qop ')' { SectionL $2 $3 } | '(' qopm infixexp ')' { SectionR $2 $3 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 4455fdba1e..0d0a01f660 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -38,6 +38,7 @@ module RdrHsSyn ( RdrNameRuleBndr, RdrNameDeprecation, RdrNameHsRecordBinds, + RdrNameFixitySig, RdrBinding(..), RdrMatch(..), @@ -106,13 +107,14 @@ type RdrNameMatch = Match RdrName RdrNamePat type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName -type RdrNameHsTyVar = HsTyVar RdrName +type RdrNameHsTyVar = HsTyVarBndr RdrName type RdrNameSig = Sig RdrName type RdrNameStmt = Stmt RdrName RdrNamePat type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat type RdrNameRuleBndr = RuleBndr RdrName type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat -type RdrNameDeprecation = Deprecation RdrName +type RdrNameDeprecation = DeprecDecl RdrName +type RdrNameFixitySig = FixitySig RdrName type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat @@ -159,15 +161,14 @@ extract_pred (HsPIParam n ty) acc = extract_ty ty acc extract_tys tys acc = foldr extract_ty acc tys -extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoListTy ty) acc = extract_ty ty acc -extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys -extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoIParamTy n ty) acc = extract_ty ty acc -extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys -extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc -extract_ty (MonoUsgForAllTy uv ty) acc = extract_ty ty acc -extract_ty (MonoTyVar tv) acc = tv : acc +extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys +extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsPredTy p) acc = extract_pred p acc +extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc +extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc +extract_ty (HsTyVar tv) acc = tv : acc extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc) extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ @@ -293,7 +294,7 @@ cvValSig sig = sig cvInstDeclSig sig = sig cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name") - (panic "cvClassOpSig:dm_present") + False poly_ty src_loc cvClassOpSig sig = sig \end{code} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index a24196185d..ad67d07d5a 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -5,7 +5,7 @@ \begin{code} module PrelInfo ( - module ThinAir, + module PrelNames, module MkId, builtinNames, -- Names of things whose *unique* must be known, but @@ -18,51 +18,27 @@ module PrelInfo ( -- deriving(C) clause - -- Random other things - main_NAME, ioTyCon_NAME, - deRefStablePtr_NAME, makeStablePtr_NAME, - bindIO_NAME, returnIO_NAME, + + -- Primop RdrNames + eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, + eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, ltH_Float_RDR, + eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR, + geH_RDR, leH_RDR, minusH_RDR, tagToEnumH_RDR, + -- Random other things maybeCharLikeCon, maybeIntLikeCon, needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass, isCreturnableClass, numericTyKeys, fractionalClassKeys, - -- RdrNames for lots of things, mainly used in derivings - eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, - compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, - enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR, - ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, - readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, - ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR, - eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, - ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, - ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, - and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR, - error_RDR, assertErr_RDR, getTag_RDR, tagToEnumH_RDR, - showString_RDR, showParen_RDR, readParen_RDR, lex_RDR, - showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, - - numClass_RDR, fractionalClass_RDR, eqClass_RDR, - ccallableClass_RDR, creturnableClass_RDR, - monadClass_RDR, enumClass_RDR, ordClass_RDR, - ioDataCon_RDR, - - main_RDR, - - mkTupConRdrName, mkUbxTupConRdrName - ) where #include "HsVersions.h" - - -- friends: -import ThinAir -- Re-export all these import MkId -- Ditto +import PrelNames -- Prelude module names -import PrelMods -- Prelude module names import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName ) import DataCon ( DataCon, dataConId, dataConWrapId ) import PrimRep ( PrimRep(..) ) @@ -70,18 +46,18 @@ import TysPrim -- TYPES import TysWiredIn -- others: -import RdrName ( RdrName, mkPreludeQual ) +import RdrName ( RdrName ) import Var ( varUnique, Id ) import Name ( Name, OccName, Provenance(..), NameSpace, tcName, clsName, varName, dataName, mkKnownKeyGlobal, getName, mkGlobalName, nameRdrName ) -import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual ) import Class ( Class, classKey ) -import TyCon ( tyConDataCons, TyCon ) +import TyCon ( tyConDataConsIfAvailable, TyCon ) import Type ( funTyCon ) import Bag +import BasicTypes ( Boxity(..) ) import Unique -- *Key stuff import UniqFM ( UniqFM, listToUFM ) import Util ( isIn ) @@ -110,9 +86,6 @@ builtinNames -- PrimOps , listToBag (map (getName . mkPrimOpId) allThePrimOps) - -- Thin-air ids - , listToBag thinAirIdNames - -- Other names with magic keys , listToBag knownKeyNames ] @@ -123,7 +96,7 @@ builtinNames getTyConNames :: TyCon -> Bag Name getTyConNames tycon = getName tycon `consBag` - unionManyBags (map get_data_con_names (tyConDataCons tycon)) + unionManyBags (map get_data_con_names (tyConDataConsIfAvailable tycon)) -- Synonyms return empty list of constructors where get_data_con_names dc = listToBag [getName (dataConId dc), -- Worker @@ -137,6 +110,35 @@ sense of them in interface pragmas. It's cool, though they all have %************************************************************************ %* * +\subsection{RdrNames for the primops} +%* * +%************************************************************************ + +These can't be in PrelNames, because we get the RdrName from the PrimOp, +which is above PrelNames in the module hierarchy. + +\begin{code} +eqH_Char_RDR = primOpRdrName CharEqOp +ltH_Char_RDR = primOpRdrName CharLtOp +eqH_Word_RDR = primOpRdrName WordEqOp +ltH_Word_RDR = primOpRdrName WordLtOp +eqH_Addr_RDR = primOpRdrName AddrEqOp +ltH_Addr_RDR = primOpRdrName AddrLtOp +eqH_Float_RDR = primOpRdrName FloatEqOp +ltH_Float_RDR = primOpRdrName FloatLtOp +eqH_Double_RDR = primOpRdrName DoubleEqOp +ltH_Double_RDR = primOpRdrName DoubleLtOp +eqH_Int_RDR = primOpRdrName IntEqOp +ltH_Int_RDR = primOpRdrName IntLtOp +geH_RDR = primOpRdrName IntGeOp +leH_RDR = primOpRdrName IntLeOp +minusH_RDR = primOpRdrName IntSubOp + +tagToEnumH_RDR = primOpRdrName TagToEnumOp +\end{code} + +%************************************************************************ +%* * \subsection{Wired in TyCons} %* * %************************************************************************ @@ -172,8 +174,8 @@ prim_tycons , word64PrimTyCon ] -tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ] -unboxed_tuple_tycons = [unboxedTupleTyCon i | i <- [1..37] ] +tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ] +unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ] data_tycons = [ addrTyCon @@ -198,23 +200,14 @@ data_tycons Ids, Synonyms, Classes and ClassOps with builtin keys. \begin{code} -ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey) -main_NAME = mkKnownKeyGlobal (main_RDR, mainKey) - - -- Operations needed when compiling FFI decls -bindIO_NAME = mkKnownKeyGlobal (bindIO_RDR, bindIOIdKey) -returnIO_NAME = mkKnownKeyGlobal (returnIO_RDR, returnIOIdKey) -deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey) -makeStablePtr_NAME = mkKnownKeyGlobal (makeStablePtr_RDR, makeStablePtrIdKey) - knownKeyNames :: [Name] knownKeyNames - = [main_NAME, ioTyCon_NAME] - ++ - map mkKnownKeyGlobal + = map mkKnownKeyGlobal [ -- Type constructors (synonyms especially) - (orderingTyCon_RDR, orderingTyConKey) + (ioTyCon_RDR, ioTyConKey) + , (main_RDR, mainKey) + , (orderingTyCon_RDR, orderingTyConKey) , (rationalTyCon_RDR, rationalTyConKey) , (ratioDataCon_RDR, ratioDataConKey) , (ratioTyCon_RDR, ratioTyConKey) @@ -268,14 +261,21 @@ knownKeyNames , (makeStablePtr_RDR, makeStablePtrIdKey) , (bindIO_RDR, bindIOIdKey) , (returnIO_RDR, returnIOIdKey) + , (addr2Integer_RDR, addr2IntegerIdKey) + -- Strings and lists , (map_RDR, mapIdKey) , (append_RDR, appendIdKey) + , (unpackCString_RDR, unpackCStringIdKey) + , (unpackCString2_RDR, unpackCString2IdKey) + , (unpackCStringAppend_RDR, unpackCStringAppendIdKey) + , (unpackCStringFoldr_RDR, unpackCStringFoldrIdKey) -- List operations , (concat_RDR, concatIdKey) , (filter_RDR, filterIdKey) , (zip_RDR, zipIdKey) + , (foldr_RDR, foldrIdKey) , (build_RDR, buildIdKey) , (augment_RDR, augmentIdKey) @@ -300,203 +300,12 @@ ToDo: make it do the ``like'' part properly (as in 0.26 and before). \begin{code} maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool -maybeCharLikeCon con = getUnique con == charDataConKey -maybeIntLikeCon con = getUnique con == intDataConKey +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey \end{code} %************************************************************************ %* * -\subsection{Commonly-used RdrNames} -%* * -%************************************************************************ - -These RdrNames are not really "built in", but some parts of the compiler -(notably the deriving mechanism) need to mention their names, and it's convenient -to write them all down in one place. - -\begin{code} -main_RDR = varQual mAIN_Name SLIT("main") -otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise") - -intTyCon_RDR = nameRdrName (getName intTyCon) -ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") -ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") -bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") -returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") - -orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") - -rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") -ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") -ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") - -byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") -mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") - -foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") -stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") -stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr") -deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr") -makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr") - --- Random PrelBase data constructors -mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#") -false_RDR = dataQual pREL_BASE_Name SLIT("False") -true_RDR = dataQual pREL_BASE_Name SLIT("True") - --- Random PrelBase functions -and_RDR = varQual pREL_BASE_Name SLIT("&&") -not_RDR = varQual pREL_BASE_Name SLIT("not") -compose_RDR = varQual pREL_BASE_Name SLIT(".") -append_RDR = varQual pREL_BASE_Name SLIT("++") -map_RDR = varQual pREL_BASE_Name SLIT("map") -build_RDR = varQual pREL_BASE_Name SLIT("build") -augment_RDR = varQual pREL_BASE_Name SLIT("augment") - --- Classes Eq and Ord -eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq") -ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord") -eq_RDR = varQual pREL_BASE_Name SLIT("==") -ne_RDR = varQual pREL_BASE_Name SLIT("/=") -le_RDR = varQual pREL_BASE_Name SLIT("<=") -lt_RDR = varQual pREL_BASE_Name SLIT("<") -ge_RDR = varQual pREL_BASE_Name SLIT(">=") -gt_RDR = varQual pREL_BASE_Name SLIT(">") -ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT") -eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ") -gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT") -max_RDR = varQual pREL_BASE_Name SLIT("max") -min_RDR = varQual pREL_BASE_Name SLIT("min") -compare_RDR = varQual pREL_BASE_Name SLIT("compare") - --- Class Monad -monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad") -monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus") -thenM_RDR = varQual pREL_BASE_Name SLIT(">>=") -returnM_RDR = varQual pREL_BASE_Name SLIT("return") -failM_RDR = varQual pREL_BASE_Name SLIT("fail") - --- Class Functor -functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor") - --- Class Show -showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show") -showList___RDR = varQual pREL_SHOW_Name SLIT("showList__") -showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec") -showList_RDR = varQual pREL_SHOW_Name SLIT("showList") -showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace") -showString_RDR = varQual pREL_SHOW_Name SLIT("showString") -showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen") - - --- Class Read -readClass_RDR = clsQual pREL_READ_Name SLIT("Read") -readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec") -readList_RDR = varQual pREL_READ_Name SLIT("readList") -readParen_RDR = varQual pREL_READ_Name SLIT("readParen") -lex_RDR = varQual pREL_READ_Name SLIT("lex") -readList___RDR = varQual pREL_READ_Name SLIT("readList__") - - --- Class Num -numClass_RDR = clsQual pREL_NUM_Name SLIT("Num") -fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt") -fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger") -minus_RDR = varQual pREL_NUM_Name SLIT("-") -negate_RDR = varQual pREL_NUM_Name SLIT("negate") -plus_RDR = varQual pREL_NUM_Name SLIT("+") -times_RDR = varQual pREL_NUM_Name SLIT("*") - --- Other numberic classes -realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") -integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") -realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") -fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") -fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") - -floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") -realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") - --- Class Ix -ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix") -range_RDR = varQual pREL_ARR_Name SLIT("range") -index_RDR = varQual pREL_ARR_Name SLIT("index") -inRange_RDR = varQual pREL_ARR_Name SLIT("inRange") - --- Class CCallable and CReturnable -ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") -creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable") - --- Class Enum -enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum") -succ_RDR = varQual pREL_ENUM_Name SLIT("succ") -pred_RDR = varQual pREL_ENUM_Name SLIT("pred") -toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum") -fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum") -enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom") -enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo") -enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen") -enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo") - --- Class Bounded -boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded") -minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound") -maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound") - - --- List functions -concat_RDR = varQual pREL_LIST_Name SLIT("concat") -filter_RDR = varQual pREL_LIST_Name SLIT("filter") -zip_RDR = varQual pREL_LIST_Name SLIT("zip") - -int8TyCon_RDR = tcQual iNT_Name SLIT("Int8") -int16TyCon_RDR = tcQual iNT_Name SLIT("Int16") -int32TyCon_RDR = tcQual iNT_Name SLIT("Int32") -int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64") - -word8TyCon_RDR = tcQual wORD_Name SLIT("Word8") -word16TyCon_RDR = tcQual wORD_Name SLIT("Word16") -word32TyCon_RDR = tcQual wORD_Name SLIT("Word32") -word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64") - -error_RDR = varQual pREL_ERR_Name SLIT("error") -assert_RDR = varQual pREL_GHC_Name SLIT("assert") -assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError") -runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep") - -eqH_Char_RDR = primOpRdrName CharEqOp -ltH_Char_RDR = primOpRdrName CharLtOp -eqH_Word_RDR = primOpRdrName WordEqOp -ltH_Word_RDR = primOpRdrName WordLtOp -eqH_Addr_RDR = primOpRdrName AddrEqOp -ltH_Addr_RDR = primOpRdrName AddrLtOp -eqH_Float_RDR = primOpRdrName FloatEqOp -ltH_Float_RDR = primOpRdrName FloatLtOp -eqH_Double_RDR = primOpRdrName DoubleEqOp -ltH_Double_RDR = primOpRdrName DoubleLtOp -eqH_Int_RDR = primOpRdrName IntEqOp -ltH_Int_RDR = primOpRdrName IntLtOp -geH_RDR = primOpRdrName IntGeOp -leH_RDR = primOpRdrName IntLeOp -minusH_RDR = primOpRdrName IntSubOp - -tagToEnumH_RDR = primOpRdrName TagToEnumOp -getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#") -\end{code} - -\begin{code} -mkTupConRdrName :: Int -> RdrName -mkTupConRdrName arity = case mkTupNameStr arity of - (mod, occ) -> dataQual mod occ - -mkUbxTupConRdrName :: Int -> RdrName -mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of - (mod, occ) -> dataQual mod occ -\end{code} - - -%************************************************************************ -%* * \subsection[Class-std-groups]{Standard groups of Prelude classes} %* * %************************************************************************ @@ -633,17 +442,3 @@ noDictClassKeys -- These classes are used only for type annotations; = cCallishClassKeys \end{code} - -%************************************************************************ -%* * -\subsection{Local helpers} -%* * -%************************************************************************ - -\begin{code} -varQual = mkPreludeQual varName -dataQual = mkPreludeQual dataName -tcQual = mkPreludeQual tcName -clsQual = mkPreludeQual clsName -\end{code} - diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs deleted file mode 100644 index 885685d7c4..0000000000 --- a/ghc/compiler/prelude/PrelMods.lhs +++ /dev/null @@ -1,101 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[PrelMods]{Definitions of prelude modules} - -The strings identify built-in prelude modules. They are -defined here so as to avod - -[oh dear, looks like the recursive module monster caught up with - and gobbled whoever was writing the above :-) -- SOF ] - -\begin{code} -module PrelMods - ( - mkTupNameStr, mkUbxTupNameStr, - - pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, - pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, - - pREL_GHC_Name, pRELUDE_Name, - mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, - pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name, - pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name, - pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name, - pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name, - pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name, - pREL_REAL_Name, pREL_FLOAT_Name - ) where - -#include "HsVersions.h" - -import Module ( Module, ModuleName, mkPrelModule, mkSrcModule ) -import Util ( nOfThem ) -import Panic ( panic ) -\end{code} - -\begin{code} -pRELUDE_Name = mkSrcModule "Prelude" -pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values -pREL_BASE_Name = mkSrcModule "PrelBase" -pREL_ENUM_Name = mkSrcModule "PrelEnum" -pREL_SHOW_Name = mkSrcModule "PrelShow" -pREL_READ_Name = mkSrcModule "PrelRead" -pREL_NUM_Name = mkSrcModule "PrelNum" -pREL_LIST_Name = mkSrcModule "PrelList" -pREL_TUP_Name = mkSrcModule "PrelTup" -pREL_PACK_Name = mkSrcModule "PrelPack" -pREL_CONC_Name = mkSrcModule "PrelConc" -pREL_IO_BASE_Name = mkSrcModule "PrelIOBase" -pREL_ST_Name = mkSrcModule "PrelST" -pREL_ARR_Name = mkSrcModule "PrelArr" -pREL_BYTEARR_Name = mkSrcModule "PrelByteArr" -pREL_FOREIGN_Name = mkSrcModule "PrelForeign" -pREL_STABLE_Name = mkSrcModule "PrelStable" -pREL_ADDR_Name = mkSrcModule "PrelAddr" -pREL_ERR_Name = mkSrcModule "PrelErr" -pREL_REAL_Name = mkSrcModule "PrelReal" -pREL_FLOAT_Name = mkSrcModule "PrelFloat" - -pREL_MAIN_Name = mkSrcModule "PrelMain" -mAIN_Name = mkSrcModule "Main" -iNT_Name = mkSrcModule "Int" -wORD_Name = mkSrcModule "Word" - -pREL_GHC = mkPrelModule pREL_GHC_Name -pREL_BASE = mkPrelModule pREL_BASE_Name -pREL_ADDR = mkPrelModule pREL_ADDR_Name -pREL_STABLE = mkPrelModule pREL_STABLE_Name -pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name -pREL_PACK = mkPrelModule pREL_PACK_Name -pREL_ERR = mkPrelModule pREL_ERR_Name -pREL_NUM = mkPrelModule pREL_NUM_Name -pREL_REAL = mkPrelModule pREL_REAL_Name -pREL_FLOAT = mkPrelModule pREL_FLOAT_Name -\end{code} - -%************************************************************************ -%* * -\subsection{Constructing the names of tuples -%* * -%************************************************************************ - -\begin{code} -mkTupNameStr, mkUbxTupNameStr :: Int -> (ModuleName, FAST_STRING) - -mkTupNameStr 0 = (pREL_BASE_Name, SLIT("()")) -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary -mkTupNameStr 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto -mkTupNameStr 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto -mkTupNameStr n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) - -mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???" -mkUbxTupNameStr 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!! -mkUbxTupNameStr 2 = (pREL_GHC_Name, _PK_ "(#,#)") -mkUbxTupNameStr 3 = (pREL_GHC_Name, _PK_ "(#,,#)") -mkUbxTupNameStr 4 = (pREL_GHC_Name, _PK_ "(#,,,#)") -mkUbxTupNameStr n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) -\end{code} - - diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs new file mode 100644 index 0000000000..0d4328d278 --- /dev/null +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -0,0 +1,341 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[PrelNames]{Definitions of prelude modules} + +The strings identify built-in prelude modules. They are +defined here so as to avod + +[oh dear, looks like the recursive module monster caught up with + and gobbled whoever was writing the above :-) -- SOF ] + +\begin{code} +module PrelNames + ( + -- Prelude modules + pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, + pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, + + -- Module names (both Prelude and otherwise) + pREL_GHC_Name, pRELUDE_Name, + mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, + pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name, + pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name, + pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name, + pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name, + pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name, + pREL_REAL_Name, pREL_FLOAT_Name, + + -- RdrNames for lots of things, mainly used in derivings + eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, + compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, + enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR, + ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, + readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR, false_RDR, true_RDR, + and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR, + error_RDR, assertErr_RDR, + showString_RDR, showParen_RDR, readParen_RDR, lex_RDR, + showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, + addr2Integer_RDR, ioTyCon_RDR, + foldr_RDR, build_RDR, getTag_RDR, + + orderingTyCon_RDR, rationalTyCon_RDR, ratioTyCon_RDR, byteArrayTyCon_RDR, + mutableByteArrayTyCon_RDR, foreignObjTyCon_RDR, + intTyCon_RDR, stablePtrTyCon_RDR, stablePtrDataCon_RDR, + int8TyCon_RDR, int16TyCon_RDR, int32TyCon_RDR, int64TyCon_RDR, + word8TyCon_RDR, word16TyCon_RDR, word32TyCon_RDR, word64TyCon_RDR, + + boundedClass_RDR, monadPlusClass_RDR, functorClass_RDR, showClass_RDR, + realClass_RDR, integralClass_RDR, floatingClass_RDR, realFracClass_RDR, + realFloatClass_RDR, readClass_RDR, ixClass_RDR, + fromInt_RDR, fromInteger_RDR, minus_RDR, fromRational_RDR, + + bindIO_RDR, returnIO_RDR, thenM_RDR, returnM_RDR, failM_RDR, + + deRefStablePtr_RDR, makeStablePtr_RDR, + concat_RDR, filter_RDR, zip_RDR, augment_RDR, + otherwiseId_RDR, assert_RDR, runSTRep_RDR, + + unpackCString_RDR, unpackCString2_RDR, unpackCStringAppend_RDR, unpackCStringFoldr_RDR, + numClass_RDR, fractionalClass_RDR, eqClass_RDR, + ccallableClass_RDR, creturnableClass_RDR, + monadClass_RDR, enumClass_RDR, ordClass_RDR, + ioDataCon_RDR, + + main_RDR, + + mkTupNameStr, mkTupConRdrName + + ) where + +#include "HsVersions.h" + +import Module ( Module, ModuleName, mkPrelModule, mkSrcModule ) +import OccName ( NameSpace, varName, dataName, tcName, clsName ) +import RdrName ( RdrName, mkPreludeQual ) +import BasicTypes ( Boxity(..), Arity ) +import Util ( nOfThem ) +import Panic ( panic ) +\end{code} + +%************************************************************************ +%* * +\subsection{Module names} +%* * +%************************************************************************ + +\begin{code} +pRELUDE_Name = mkSrcModule "Prelude" +pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values +pREL_BASE_Name = mkSrcModule "PrelBase" +pREL_ENUM_Name = mkSrcModule "PrelEnum" +pREL_SHOW_Name = mkSrcModule "PrelShow" +pREL_READ_Name = mkSrcModule "PrelRead" +pREL_NUM_Name = mkSrcModule "PrelNum" +pREL_LIST_Name = mkSrcModule "PrelList" +pREL_TUP_Name = mkSrcModule "PrelTup" +pREL_PACK_Name = mkSrcModule "PrelPack" +pREL_CONC_Name = mkSrcModule "PrelConc" +pREL_IO_BASE_Name = mkSrcModule "PrelIOBase" +pREL_ST_Name = mkSrcModule "PrelST" +pREL_ARR_Name = mkSrcModule "PrelArr" +pREL_BYTEARR_Name = mkSrcModule "PrelByteArr" +pREL_FOREIGN_Name = mkSrcModule "PrelForeign" +pREL_STABLE_Name = mkSrcModule "PrelStable" +pREL_ADDR_Name = mkSrcModule "PrelAddr" +pREL_ERR_Name = mkSrcModule "PrelErr" +pREL_REAL_Name = mkSrcModule "PrelReal" +pREL_FLOAT_Name = mkSrcModule "PrelFloat" + +pREL_MAIN_Name = mkSrcModule "PrelMain" +mAIN_Name = mkSrcModule "Main" +iNT_Name = mkSrcModule "Int" +wORD_Name = mkSrcModule "Word" + +pREL_GHC = mkPrelModule pREL_GHC_Name +pREL_BASE = mkPrelModule pREL_BASE_Name +pREL_ADDR = mkPrelModule pREL_ADDR_Name +pREL_STABLE = mkPrelModule pREL_STABLE_Name +pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name +pREL_PACK = mkPrelModule pREL_PACK_Name +pREL_ERR = mkPrelModule pREL_ERR_Name +pREL_NUM = mkPrelModule pREL_NUM_Name +pREL_REAL = mkPrelModule pREL_REAL_Name +pREL_FLOAT = mkPrelModule pREL_FLOAT_Name +\end{code} + +%************************************************************************ +%* * +\subsection{Constructing the names of tuples +%* * +%************************************************************************ + +\begin{code} +mkTupNameStr :: Boxity -> Int -> (ModuleName, FAST_STRING) + +mkTupNameStr Boxed 0 = (pREL_BASE_Name, SLIT("()")) +mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???" +mkTupNameStr Boxed 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary +mkTupNameStr Boxed 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto +mkTupNameStr Boxed 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto +mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) + +mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???" +mkTupNameStr Unboxed 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!! +mkTupNameStr Unboxed 2 = (pREL_GHC_Name, _PK_ "(#,#)") +mkTupNameStr Unboxed 3 = (pREL_GHC_Name, _PK_ "(#,,#)") +mkTupNameStr Unboxed 4 = (pREL_GHC_Name, _PK_ "(#,,,#)") +mkTupNameStr Unboxed n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) + +mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName +mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of + (mod, occ) -> mkPreludeQual space mod occ +\end{code} + + + +%************************************************************************ +%* * +\subsection{Commonly-used RdrNames} +%* * +%************************************************************************ + +These RdrNames are not really "built in", but some parts of the compiler +(notably the deriving mechanism) need to mention their names, and it's convenient +to write them all down in one place. + +\begin{code} +main_RDR = varQual mAIN_Name SLIT("main") + +ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") +ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") +bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") +returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") + + +rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") +ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") +ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") + +byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") +mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") + +foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") +stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") +stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr") +deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr") +makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr") + +-- Random PrelBase data types and constructors +intTyCon_RDR = tcQual pREL_BASE_Name SLIT("Int") +orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") +mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#") +false_RDR = dataQual pREL_BASE_Name SLIT("False") +true_RDR = dataQual pREL_BASE_Name SLIT("True") + +-- Random PrelBase functions +otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise") +and_RDR = varQual pREL_BASE_Name SLIT("&&") +not_RDR = varQual pREL_BASE_Name SLIT("not") +compose_RDR = varQual pREL_BASE_Name SLIT(".") +append_RDR = varQual pREL_BASE_Name SLIT("++") +foldr_RDR = varQual pREL_BASE_Name SLIT("foldr") +map_RDR = varQual pREL_BASE_Name SLIT("map") +build_RDR = varQual pREL_BASE_Name SLIT("build") +augment_RDR = varQual pREL_BASE_Name SLIT("augment") + +-- Strings +unpackCString_RDR = varQual pREL_BASE_Name SLIT("unpackCString#") +unpackCString2_RDR = varQual pREL_BASE_Name SLIT("unpackNBytes#") +unpackCStringAppend_RDR = varQual pREL_BASE_Name SLIT("unpackAppendCString#") +unpackCStringFoldr_RDR = varQual pREL_BASE_Name SLIT("unpackFoldrCString#") + +-- Classes Eq and Ord +eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq") +ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord") +eq_RDR = varQual pREL_BASE_Name SLIT("==") +ne_RDR = varQual pREL_BASE_Name SLIT("/=") +le_RDR = varQual pREL_BASE_Name SLIT("<=") +lt_RDR = varQual pREL_BASE_Name SLIT("<") +ge_RDR = varQual pREL_BASE_Name SLIT(">=") +gt_RDR = varQual pREL_BASE_Name SLIT(">") +ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT") +eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ") +gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT") +max_RDR = varQual pREL_BASE_Name SLIT("max") +min_RDR = varQual pREL_BASE_Name SLIT("min") +compare_RDR = varQual pREL_BASE_Name SLIT("compare") + +-- Class Monad +monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad") +monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus") +thenM_RDR = varQual pREL_BASE_Name SLIT(">>=") +returnM_RDR = varQual pREL_BASE_Name SLIT("return") +failM_RDR = varQual pREL_BASE_Name SLIT("fail") + +-- Class Functor +functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor") + +-- Class Show +showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show") +showList___RDR = varQual pREL_SHOW_Name SLIT("showList__") +showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec") +showList_RDR = varQual pREL_SHOW_Name SLIT("showList") +showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace") +showString_RDR = varQual pREL_SHOW_Name SLIT("showString") +showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen") + + +-- Class Read +readClass_RDR = clsQual pREL_READ_Name SLIT("Read") +readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec") +readList_RDR = varQual pREL_READ_Name SLIT("readList") +readParen_RDR = varQual pREL_READ_Name SLIT("readParen") +lex_RDR = varQual pREL_READ_Name SLIT("lex") +readList___RDR = varQual pREL_READ_Name SLIT("readList__") + + +-- Class Num +numClass_RDR = clsQual pREL_NUM_Name SLIT("Num") +fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt") +fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger") +minus_RDR = varQual pREL_NUM_Name SLIT("-") +negate_RDR = varQual pREL_NUM_Name SLIT("negate") +plus_RDR = varQual pREL_NUM_Name SLIT("+") +times_RDR = varQual pREL_NUM_Name SLIT("*") +addr2Integer_RDR = varQual pREL_NUM_Name SLIT("addr2Integer") + +-- Other numberic classes +realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") +integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") +realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") +fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") +fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") + +floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") +realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") + +-- Class Ix +ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix") +range_RDR = varQual pREL_ARR_Name SLIT("range") +index_RDR = varQual pREL_ARR_Name SLIT("index") +inRange_RDR = varQual pREL_ARR_Name SLIT("inRange") + +-- Class CCallable and CReturnable +ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") +creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable") + +-- Class Enum +enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum") +succ_RDR = varQual pREL_ENUM_Name SLIT("succ") +pred_RDR = varQual pREL_ENUM_Name SLIT("pred") +toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum") +fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum") +enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom") +enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo") +enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen") +enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo") + +-- Class Bounded +boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded") +minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound") +maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound") + + +-- List functions +concat_RDR = varQual pREL_LIST_Name SLIT("concat") +filter_RDR = varQual pREL_LIST_Name SLIT("filter") +zip_RDR = varQual pREL_LIST_Name SLIT("zip") + +int8TyCon_RDR = tcQual iNT_Name SLIT("Int8") +int16TyCon_RDR = tcQual iNT_Name SLIT("Int16") +int32TyCon_RDR = tcQual iNT_Name SLIT("Int32") +int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64") + +word8TyCon_RDR = tcQual wORD_Name SLIT("Word8") +word16TyCon_RDR = tcQual wORD_Name SLIT("Word16") +word32TyCon_RDR = tcQual wORD_Name SLIT("Word32") +word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64") + +error_RDR = varQual pREL_ERR_Name SLIT("error") +assert_RDR = varQual pREL_GHC_Name SLIT("assert") +getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#") +assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError") +runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep") +\end{code} + + +%************************************************************************ +%* * +\subsection{Local helpers} +%* * +%************************************************************************ + +\begin{code} +varQual = mkPreludeQual varName +dataQual = mkPreludeQual dataName +tcQual = mkPreludeQual tcName +clsQual = mkPreludeQual clsName +\end{code} + diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 63e986330c..5f2c0df729 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -21,15 +21,17 @@ import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit ) +import RdrName ( RdrName ) import PrimOp ( PrimOp(..), primOpOcc ) import TysWiredIn ( trueDataConId, falseDataConId ) -import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon ) +import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon ) import DataCon ( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG ) import CoreUnfold ( maybeUnfoldingTemplate ) import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) import Type ( splitTyConApp_maybe ) import OccName ( occNameUserString) -import ThinAir ( unpackCStringFoldrId ) +import PrelNames ( unpackCStringFoldr_RDR ) +import Unique ( unpackCStringFoldrIdKey, hasKey ) import Maybes ( maybeToBool ) import Char ( ord, chr ) import Bits ( Bits(..) ) @@ -55,7 +57,7 @@ primOpRule op = BuiltinRule (primop_rule op) where op_name = _PK_ (occNameUserString (primOpOcc op)) - op_name_case = op_name _APPEND_ SLIT("case") + op_name_case = op_name _APPEND_ SLIT("->case") -- ToDo: something for integer-shift ops? -- NotOp @@ -404,11 +406,15 @@ seqRule other = Nothing \begin{code} tagToEnumRule [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) - Just (SLIT("TagToEnum"), Var (dataConId dc)) + case filter correct_tag (tyConDataConsIfAvailable tycon) of + + + [] -> Nothing -- Abstract type + (dc:rest) -> ASSERT( null rest ) + Just (SLIT("TagToEnum"), Var (dataConId dc)) where + correct_tag dc = (dataConTag dc - fIRST_TAG) == tag tag = fromInteger i - constrs = tyConDataCons tycon - (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ] (Just (tycon,_)) = splitTyConApp_maybe ty tagToEnumRule other = Nothing @@ -438,15 +444,14 @@ dataToTagRule other = Nothing %************************************************************************ \begin{code} -builtinRules :: [ProtoCoreRule] +builtinRules :: [(RdrName, CoreRule)] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ ProtoCoreRule False unpackCStringFoldrId - (BuiltinRule match_append_lit_str) + = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str) ] --- unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n match_append_lit_str [Type ty1, Lit (MachStr s1), @@ -456,7 +461,7 @@ match_append_lit_str [Type ty1, `App` c2 `App` n ] - | unpk == unpackCStringFoldrId && + | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 = ASSERT( ty1 == ty2 ) Just (SLIT("AppendLitString"), diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 7a0627d6f0..a55af165de 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -42,9 +42,9 @@ import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys, UsageAnn(..), mkUsgTy ) import Unique ( Unique, mkPrimOpIdUnique ) -import BasicTypes ( Arity ) +import BasicTypes ( Arity, Boxity(..) ) import CStrings ( CLabelString, pprCLabelString ) -import PrelMods ( pREL_GHC, pREL_GHC_Name ) +import PrelNames ( pREL_GHC, pREL_GHC_Name ) import Outputable import Util ( assoc, zipWithEqual ) import GlaExts ( Int(..), Int#, (==#) ) @@ -832,9 +832,10 @@ an_Integer_and_Int_tys = [intPrimTy, byteArrayPrimTy, -- Integer intPrimTy] -unboxedPair = mkUnboxedTupleTy 2 -unboxedTriple = mkUnboxedTupleTy 3 -unboxedQuadruple = mkUnboxedTupleTy 4 +unboxedSingleton = mkTupleTy Unboxed 1 +unboxedPair = mkTupleTy Unboxed 2 +unboxedTriple = mkTupleTy Unboxed 3 +unboxedQuadruple = mkTupleTy Unboxed 4 mkIOTy ty = mkFunTy realWorldStatePrimTy (unboxedPair [realWorldStatePrimTy,ty]) @@ -1270,7 +1271,7 @@ primOpInfo WriteArrayOp primOpInfo IndexArrayOp = let { elt = alphaTy; elt_tv = alphaTyVar } in mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy] - (mkUnboxedTupleTy 1 [elt]) + (unboxedSingleton [elt]) --------------------------------------------------------------------------- -- Primitive arrays full of unboxed bytes: @@ -2302,8 +2303,8 @@ primOpUsg op Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty) inUB fs ty = case splitTyConApp_maybe ty of - Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) ) - mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg" + Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) + mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys) Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty) \end{code} @@ -2409,6 +2410,7 @@ data CCall Bool -- True <=> really a "casm" Bool -- True <=> might invoke Haskell GC CallConv -- calling convention to use. + deriving( Eq ) data CCallTarget = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. @@ -2416,6 +2418,7 @@ data CCallTarget -- (unique is used to generate a 'typedef' to cast -- the function pointer if compiling the ccall# down to -- .hc code - can't do this inline for tedious reasons.) + deriving( Eq ) ccallMayGC :: CCall -> Bool ccallMayGC (CCall _ _ may_gc _) = may_gc diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs deleted file mode 100644 index 8852598b64..0000000000 --- a/ghc/compiler/prelude/ThinAir.lhs +++ /dev/null @@ -1,109 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section{Thin air Ids} - -\begin{code} -module ThinAir ( - thinAirIdNames, -- Names of non-wired-in Ids that may be used out of - setThinAirIds, -- thin air in any compilation. If they are not wired in - -- we must be sure to import them from some Prelude - -- interface file even if they are not overtly - -- mentioned. Subset of builtinNames. - -- Here are the thin-air Ids themselves - addr2IntegerId, - unpackCStringId, unpackCString2Id, - unpackCStringAppendId, unpackCStringFoldrId, - foldrId, buildId, - - noRepIntegerIds, - noRepStrIds - - ) where - -#include "HsVersions.h" - -import Var ( Id, varUnique ) -import Name ( mkKnownKeyGlobal, varName ) -import RdrName ( mkPreludeQual ) -import PrelMods -import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM ) -import Unique -import Outputable -import IOExts -\end{code} - - -%************************************************************************ -%* * -\subsection{Thin air entities} -%* * -%************************************************************************ - -These are Ids that we need to reference in various parts of the -system, and we'd like to pull them out of thin air rather than pass -them around. We'd also like to have all the IdInfo available for each -one: i.e. everything that gets pulled out of the interface file. - -The solution is to generate this map of global Ids after the -typechecker, and assign it to a global variable. Any subsequent -pass may refer to the map to pull Ids out. Any invalid -(i.e. pre-typechecker) access to the map will result in a panic. - -\begin{code} -thinAirIdNames - = map mkKnownKeyGlobal - [ - -- Needed for converting literals to Integers (used in tidyCoreExpr) - (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey) - - -- Folds and builds; introduced by desugaring list comprehensions - , (varQual pREL_BASE_Name SLIT("unpackNBytes#"), unpackCString2IdKey) - , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey) - , (varQual pREL_BASE_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey) - , (varQual pREL_BASE_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey) - - , (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey) - , (varQual pREL_BASE_Name SLIT("build"), buildIdKey) - ] - -varQual = mkPreludeQual varName -\end{code} - - -\begin{code} -noRepIntegerIds = [addr2IntegerId] - -noRepStrIds = [unpackCString2Id, unpackCStringId] - -addr2IntegerId = lookupThinAirId addr2IntegerIdKey - -unpackCStringId = lookupThinAirId unpackCStringIdKey -unpackCString2Id = lookupThinAirId unpackCString2IdKey -unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey -unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey - -foldrId = lookupThinAirId foldrIdKey -buildId = lookupThinAirId buildIdKey -\end{code} - -\begin{code} -{-# NOINLINE thinAirIdMapRef #-} -thinAirIdMapRef :: IORef (UniqFM Id) -thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty")) - -setThinAirIds :: [Id] -> IO () -setThinAirIds thin_air_ids - = writeIORef thinAirIdMapRef the_map - where - the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids] - -thinAirIdMap :: UniqFM Id -thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef) - -- Read it just once, the first time someone tugs on thinAirIdMap - -lookupThinAirId :: Unique -> Id -lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap - (panic "lookupThinAirId: no mapping") uniq -\end{code} - diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 694492e333..10673367a3 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -53,7 +53,7 @@ import Type ( Type, mkTyConApp, mkTyConTy, mkTyVarTys, unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds ) -import PrelMods ( pREL_GHC ) +import PrelNames ( pREL_GHC ) import Outputable import Unique \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 7a76a1acc1..a2b6ae3910 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -48,11 +48,9 @@ module TysWiredIn ( -- tuples mkTupleTy, - tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon, - - -- unboxed tuples - mkUnboxedTupleTy, - unboxedTupleTyCon, unboxedTupleCon, + tupleTyCon, tupleCon, + unitTyCon, unitDataConId, pairTyCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, stablePtrTyCon, @@ -77,7 +75,7 @@ module TysWiredIn ( import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId ) -- friends: -import PrelMods +import PrelNames import TysPrim -- others: @@ -89,7 +87,7 @@ import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons, mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) +import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, mkArrowKinds, boxedTypeKind, unboxedTypeKind, mkFunTy, mkFunTys, @@ -121,6 +119,7 @@ pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons [] -- No context argvrcs cons + (length cons) [] -- No derivings new_or_data is_rec @@ -165,88 +164,49 @@ pcDataCon wrap_key mod str tyvars context arg_tys tycon %************************************************************************ \begin{code} -tupleTyCon :: Arity -> TyCon -tupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_tuple i) -- Build one specially - | otherwise = tupleTyConArr!i - -tupleCon :: Arity -> DataCon -tupleCon i | i > mAX_TUPLE_SIZE = snd (mk_tuple i) -- Build one specially - | otherwise = tupleConArr!i - -tupleTyCons :: [TyCon] -tupleTyCons = elems tupleTyConArr - -tupleTyConArr :: Array Int TyCon -tupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst tuples) - -tupleConArr :: Array Int DataCon -tupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd tuples) - -tuples :: [(TyCon,DataCon)] -tuples = [mk_tuple i | i <- [0..mAX_TUPLE_SIZE]] - -mk_tuple :: Int -> (TyCon,DataCon) -mk_tuple arity = (tycon, tuple_con) +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleCon :: Boxity -> Arity -> DataCon +tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i) -- Build one specially +tupleCon Boxed i = snd (boxedTupleArr ! i) +tupleCon Unboxed i = snd (unboxedTupleArr ! i) + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Boxed i) | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Unboxed i) | i <- [0..mAX_TUPLE_SIZE]] + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity tc_name = mkWiredInTyConName tc_uniq mod name_str tycon - tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind + tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind + res_kind | isBoxed boxity = boxedTypeKind + | otherwise = unboxedTypeKind + + tyvars | isBoxed boxity = take arity alphaTyVars + | otherwise = take arity openAlphaTyVars tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon - tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars - (mod_name, name_str) = mkTupNameStr arity - tc_uniq = mkTupleTyConUnique arity - dc_uniq = mkTupleDataConUnique arity + (mod_name, name_str) = mkTupNameStr boxity arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity mod = mkPrelModule mod_name -unitTyCon = tupleTyCon 0 +unitTyCon = tupleTyCon Boxed 0 unitDataConId = dataConId (head (tyConDataCons unitTyCon)) -pairTyCon = tupleTyCon 2 -\end{code} +pairTyCon = tupleTyCon Boxed 2 -%************************************************************************ -%* * -\subsection[TysWiredIn-ubx-tuples]{Unboxed Tuple Types} -%* * -%************************************************************************ +unboxedSingletonTyCon = tupleTyCon Unboxed 1 +unboxedSingletonDataCon = tupleCon Unboxed 1 -\begin{code} -unboxedTupleTyCon :: Arity -> TyCon -unboxedTupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_unboxed_tuple i) - | otherwise = unboxedTupleTyConArr!i - -unboxedTupleCon :: Arity -> DataCon -unboxedTupleCon i | i > mAX_TUPLE_SIZE = snd (mk_unboxed_tuple i) - | otherwise = unboxedTupleConArr!i - -unboxedTupleTyConArr :: Array Int TyCon -unboxedTupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst ubx_tuples) - -unboxedTupleConArr :: Array Int DataCon -unboxedTupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd ubx_tuples) - -ubx_tuples :: [(TyCon,DataCon)] -ubx_tuples = [mk_unboxed_tuple i | i <- [0..mAX_TUPLE_SIZE]] - -mk_unboxed_tuple :: Int -> (TyCon,DataCon) -mk_unboxed_tuple arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con False - tc_name = mkWiredInTyConName tc_uniq mod name_str tycon - tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind - - tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon - tyvars = take arity openAlphaTyVars - tyvar_tys = mkTyVarTys tyvars - (mod_name, name_str) = mkUbxTupNameStr arity - tc_uniq = mkUbxTupleTyConUnique arity - dc_uniq = mkUbxTupleDataConUnique arity - mod = mkPrelModule mod_name - -unboxedPairTyCon = unboxedTupleTyCon 2 -unboxedPairDataCon = unboxedTupleCon 2 +unboxedPairTyCon = tupleTyCon Unboxed 2 +unboxedPairDataCon = tupleCon Unboxed 2 \end{code} %************************************************************************ @@ -589,11 +549,8 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} \begin{code} -mkTupleTy :: Int -> [Type] -> Type -mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys - -mkUnboxedTupleTy :: Int -> [Type] -> Type -mkUnboxedTupleTy arity tys = mkTyConApp (unboxedTupleTyCon arity) tys +mkTupleTy :: Boxity -> Int -> [Type] -> Type +mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys -unitTy = mkTupleTy 0 [] +unitTy = mkTupleTy Boxed 0 [] \end{code} diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 8110d2702e..cf0bf83aa8 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,3 +1,32 @@ +{- Notes about the syntax of interface files + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The header +~~~~~~~~~~ + interface "edison" M 4 6 2 ! 406 Module M, version 4, from package 'edison', + Fixities version 6, rules version 2 + Interface syntax version 406 + ! means M contains orphans + +Import declarations +~~~~~~~~~~~~~~~~~~~ + import Foo ; To compile M I used nothing from Foo, but it's + below me in the hierarchy + + import Foo ! @ ; Ditto, but the ! means that Foo contains orphans + and the @ means that Foo is a boot interface + + import Foo :: 3 ; To compile M I used everything from Foo, which has + module version 3 + + import Foo :: 3 2 6 a 1 b 3 c 7 ; To compile M I used Foo. It had + module version 3 + fixity version 2 + rules version 6 + and some specific things besides. + +-} + + { module ParseIface ( parseIface, IfaceStuff(..) ) where @@ -5,11 +34,12 @@ module ParseIface ( parseIface, IfaceStuff(..) ) where import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms -import HsTypes ( mkHsForAllTy, mkHsUsForAllTy ) +import HsTypes ( mkHsForAllTy, mkHsUsForAllTy, mkHsTupCon ) import HsCore +import Demand ( mkStrictnessInfo ) import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 ) import BasicTypes ( Fixity(..), FixityDirection(..), - NewOrData(..), Version + NewOrData(..), Version, initialVersion, Boxity(..) ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import CallConv ( cCallConv ) @@ -19,7 +49,7 @@ import IdInfo ( ArityInfo, exactArity, CprInfo(..), InlinePragInfo(..) import PrimOp ( CCall(..), CCallTarget(..) ) import Lex -import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..), +import RnMonad ( ImportVersion, ParsedIface(..), WhatsImported(..), RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..), WhetherHasOrphans, IsBootInterface ) @@ -32,11 +62,11 @@ import OccName ( mkSysOccFS, EncodedFS ) import Module ( ModuleName, PackageName, mkSysModuleFS, mkModule ) -import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName ) import SrcLoc ( SrcLoc ) import CmdLineOpts ( opt_InPackage ) import Maybes import Outputable +import List ( insert ) import GlaExts import FastString ( tailFS ) @@ -184,36 +214,42 @@ iface_stuff : iface { PIface $1 } iface :: { ParsedIface } -iface : '__interface' package mod_name INTEGER orphans checkVersion 'where' +iface : '__interface' package mod_name + version sub_versions + orphans checkVersion 'where' exports_part import_part + fix_decl_part instance_decl_part decls_part rules_and_deprecs { ParsedIface { pi_mod = mkModule $3 $2, -- Module itself - pi_vers = fromInteger $4, -- Module version - pi_orphan = $5, - pi_exports = $8, -- Exports - pi_usages = $9, -- Usages - pi_insts = $10, -- Local instances - pi_decls = $11, -- Decls - pi_rules = fst $12, -- Rules - pi_deprecs = snd $12 -- Deprecations - } } + pi_vers = $4, -- Module version + pi_orphan = $6, + pi_exports = $9, -- Exports + pi_usages = $10, -- Usages + pi_fixity = (fst $5,$11), -- Fixies + pi_insts = $12, -- Local instances + pi_decls = $13, -- Decls + pi_rules = (snd $5,fst $14), -- Rules + pi_deprecs = snd $14 -- Deprecations + } } + +-- Versions for fixities and rules (optional) +sub_versions :: { (Version,Version) } + : '[' version version ']' { ($2,$3) } + | {- empty -} { (initialVersion, initialVersion) } -------------------------------------------------------------------------- import_part :: { [ImportVersion OccName] } import_part : { [] } - | import_part import_decl { $2 : $1 } + | import_decl import_part { $1 : $2 } import_decl :: { ImportVersion OccName } -import_decl : 'import' mod_name INTEGER orphans is_boot whats_imported ';' - { (mkSysModuleFS $2, fromInteger $3, $4, $5, $6) } - -- import Foo 3 :: a 1 b 3 c 7 ; means import a,b,c from Foo - -- import Foo 3 ; means import all of Foo - -- import Foo 3 ! :: ...stuff... ; the ! means that Foo contains orphans +import_decl : 'import' mod_name orphans is_boot whats_imported ';' + { (mkSysModuleFS $2, $3, $4, $5) } orphans :: { WhetherHasOrphans } orphans : { False } @@ -224,34 +260,39 @@ is_boot : { False } | '@' { True } whats_imported :: { WhatsImported OccName } -whats_imported : { Everything } - | '::' name_version_pairs { Specifically $2 } +whats_imported : { NothingAtAll } + | '::' version { Everything $2 } + | '::' version version version name_version_pairs { Specifically $2 $3 $4 $5 } -name_version_pairs :: { [LocalVersion OccName] } +name_version_pairs :: { [(OccName, Version)] } name_version_pairs : { [] } | name_version_pair name_version_pairs { $1 : $2 } -name_version_pair :: { LocalVersion OccName } -name_version_pair : var_occ INTEGER { ($1, fromInteger $2) } - | tc_occ INTEGER { ($1, fromInteger $2) } +name_version_pair :: { (OccName, Version) } +name_version_pair : var_occ version { ($1, $2) } + | tc_occ version { ($1, $2) } -------------------------------------------------------------------------- exports_part :: { [ExportItem] } exports_part : { [] } - | exports_part '__export' - mod_name entities ';' { (mkSysModuleFS $3, $4) : $1 } + | '__export' mod_name entities ';' + exports_part { (mkSysModuleFS $2, $3) : $5 } entities :: { [RdrAvailInfo] } entities : { [] } | entity entities { $1 : $2 } entity :: { RdrAvailInfo } -entity : tc_occ { AvailTC $1 [$1] } - | var_occ { Avail $1 } - | tc_occ stuff_inside { AvailTC $1 ($1:$2) } +entity : var_occ { Avail $1 } + | tc_occ { AvailTC $1 [$1] } | tc_occ '|' stuff_inside { AvailTC $1 $3 } + | tc_occ stuff_inside { AvailTC $1 (insert $1 $2) } + -- The 'insert' is important. The stuff_inside is sorted, and + -- insert keeps it that way. This is important when comparing + -- against the new interface file, which has the stuff in sorted order + -- If they differ, we'll bump the module number when it's unnecessary stuff_inside :: { [OccName] } stuff_inside : '{' val_occs '}' { $2 } @@ -267,14 +308,24 @@ val_occs :: { [OccName] } -------------------------------------------------------------------------- +fix_decl_part :: { [RdrNameFixitySig] } +fix_decl_part : {- empty -} { [] } + | fix_decls ';' { $1 } + +fix_decls :: { [RdrNameFixitySig] } +fix_decls : { [] } + | fix_decl fix_decls { $1 : $2 } + +fix_decl :: { RdrNameFixitySig } +fix_decl : src_loc fixity prec var_or_data_name { FixitySig $4 (Fixity $3 $2) $1 } + fixity :: { FixityDirection } fixity : 'infixl' { InfixL } | 'infixr' { InfixR } | 'infix' { InfixN } -mb_fix :: { Int } -mb_fix : {-nothing-} { 9 } - | INTEGER { (fromInteger $1) } +prec :: { Int } +prec : INTEGER { fromInteger $1 } ----------------------------------------------------------------------------- @@ -283,7 +334,7 @@ csigs : { [] } | 'where' '{' csigs1 '}' { $3 } csigs1 :: { [RdrNameSig] } -csigs1 : csig { [$1] } +csigs1 : { [] } | csig ';' csigs1 { $1 : $3 } csig :: { RdrNameSig } @@ -310,22 +361,20 @@ inst_decl : src_loc 'instance' type '=' var_name ';' decls_part :: { [(Version, RdrNameHsDecl)] } decls_part : {- empty -} { [] } - | decls_part version decl ';' { ($2,$3):$1 } + | opt_version decl ';' decls_part { ($1,$2):$4 } decl :: { RdrNameHsDecl } decl : src_loc var_name '::' type maybe_idinfo { SigD (IfaceSig $2 $4 ($5 $2) $1) } | src_loc 'type' tc_name tv_bndrs '=' type { TyClD (TySynonym $3 $4 $6 $1) } - | src_loc 'data' decl_context tc_name tv_bndrs constrs - { TyClD (TyData DataType $3 $4 $5 $6 Nothing noDataPragmas $1) } - | src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr - { TyClD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) } - | src_loc 'class' decl_context tc_name tv_bndrs fds csigs + | src_loc 'data' opt_decl_context tc_name tv_bndrs constrs + { TyClD (TyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) } + | src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr + { TyClD (TyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) } + | src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds noClassPragmas $1) } - | src_loc fixity mb_fix var_or_data_name - { FixD (FixitySig $4 (Fixity $3 $2) $1) } maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] } maybe_idinfo : {- empty -} { \_ -> [] } @@ -371,7 +420,7 @@ rules :: { [RdrNameRuleDecl] } rule :: { RdrNameRuleDecl } rule : src_loc STRING rule_forall qvar_name - core_args '=' core_expr { IfaceRuleDecl $4 (UfRuleBody $2 $3 $5 $7) $1 } + core_args '=' core_expr { IfaceRule $2 $3 $4 $5 $7 $1 } rule_forall :: { [UfBinder RdrName] } rule_forall : '__forall' '{' core_bndrs '}' { $3 } @@ -380,11 +429,11 @@ rule_forall : '__forall' '{' core_bndrs '}' { $3 } deprecs :: { [RdrNameDeprecation] } deprecs : {- empty -} { [] } - | deprecs deprec ';' { $2 : $1 } + | deprec ';' deprecs { $1 : $3 } deprec :: { RdrNameDeprecation } -deprec : STRING { Deprecation (IEModuleContents undefined) $1 } - | deprec_name STRING { Deprecation $1 $2 } +deprec : src_loc STRING { Deprecation (IEModuleContents undefined) $2 $1 } + | src_loc deprec_name STRING { Deprecation $2 $3 $1 } -- SUP: TEMPORARY HACK deprec_name :: { RdrNameIE } @@ -394,11 +443,15 @@ deprec_name :: { RdrNameIE } ----------------------------------------------------------------------------- version :: { Version } -version : INTEGER { fromInteger $1 } +version : INTEGER { fromInteger $1 } -decl_context :: { RdrNameContext } -decl_context : { [] } - | '{' context_list1 '}' '=>' { $2 } +opt_version :: { Version } +opt_version : version { $1 } + | {- empty -} { initialVersion } + +opt_decl_context :: { RdrNameContext } +opt_decl_context : { [] } + | context '=>' { $1 } ---------------------------------------------------------------------------- @@ -421,9 +474,9 @@ newtype_constr : { [] } | src_loc '=' ex_stuff data_name '{' var_name '::' atype '}' { [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] } -ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) } +ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) } ex_stuff : { ([],[]) } - | '__forall' forall context '=>' { ($2,$3) } + | '__forall' tv_bndrs opt_context '=>' { ($2,$3) } batypes :: { [RdrNameBangType] } batypes : { [] } @@ -446,20 +499,21 @@ field : var_names1 '::' type { ($1, Unbanged $3) } type :: { RdrNameHsType } type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 } - | '__forall' forall context '=>' type - { mkHsForAllTy (Just $2) $3 $5 } - | btype '->' type { MonoFunTy $1 $3 } + | '__forall' tv_bndrs + opt_context '=>' type { mkHsForAllTy (Just $2) $3 $5 } + | btype '->' type { HsFunTy $1 $3 } | btype { $1 } fuall :: { [RdrName] } fuall : '[' uv_bndrs ']' { $2 } -forall :: { [HsTyVar RdrName] } -forall : '[' tv_bndrs ']' { $2 } +opt_context :: { RdrNameContext } +opt_context : { [] } + | context { $1 } context :: { RdrNameContext } -context : { [] } - | '{' context_list1 '}' { $2 } +context : '(' context_list1 ')' { $2 } + | '{' context_list1 '}' { $2 } -- Backward compatibility context_list1 :: { RdrNameContext } context_list1 : class { [$1] } @@ -480,27 +534,25 @@ types2 : type ',' type { [$1,$3] } btype :: { RdrNameHsType } btype : atype { $1 } - | btype atype { MonoTyApp $1 $2 } - | '__u' usage atype { MonoUsgTy $2 $3 } + | btype atype { HsAppTy $1 $2 } + | '__u' usage atype { HsUsgTy $2 $3 } -usage :: { MonoUsageAnn RdrName } -usage : '-' { MonoUsOnce } - | '!' { MonoUsMany } - | uv_name { MonoUsVar $1 } +usage :: { HsUsageAnn RdrName } +usage : '-' { HsUsOnce } + | '!' { HsUsMany } + | uv_name { HsUsVar $1 } atype :: { RdrNameHsType } -atype : qtc_name { MonoTyVar $1 } - | tv_name { MonoTyVar $1 } - | '(' types2 ')' { MonoTupleTy $2 True{-boxed-} } - | '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} } - | '[' type ']' { MonoListTy $2 } - | '{' qcls_name atypes '}' { MonoDictTy $2 $3 } - | '{' ipvar_name '::' type '}' { MonoIParamTy $2 $4 } +atype : qtc_name { HsTyVar $1 } + | tv_name { HsTyVar $1 } + | '(' ')' { HsTupleTy (mkHsTupCon tcName Boxed []) [] } + | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 } + | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } + | '[' type ']' { HsListTy $2 } + | '{' qcls_name atypes '}' { mkHsDictTy $2 $3 } + | '{' ipvar_name '::' type '}' { mkHsIParamTy $2 $4 } | '(' type ')' { $2 } --- This one is dealt with via qtc_name --- | '(' ')' { MonoTupleTy [] True } - atypes :: { [RdrNameHsType] {- Zero or more -} } atypes : { [] } | atype atypes { $1 : $2 } @@ -626,13 +678,17 @@ tv_name :: { RdrName } : VARID { mkSysUnqual tvName $1 } | VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} } -tv_bndr :: { HsTyVar RdrName } +tv_bndr :: { HsTyVarBndr RdrName } : tv_name '::' akind { IfaceTyVar $1 $3 } | tv_name { IfaceTyVar $1 boxedTypeKind } -tv_bndrs :: { [HsTyVar RdrName] } +tv_bndrs :: { [HsTyVarBndr RdrName] } +tv_bndrs : tv_bndrs1 { $1 } + | '[' tv_bndrs1 ']' { $2 } -- Backward compatibility + +tv_bndrs1 :: { [HsTyVarBndr RdrName] } : { [] } - | tv_bndr tv_bndrs { $1 : $2 } + | tv_bndr tv_bndrs1 { $1 : $2 } --------------------------------------------------- fds :: { [([RdrName], [RdrName])] } @@ -674,15 +730,21 @@ id_info_item :: { HsIdInfo RdrName } : '__A' INTEGER { HsArity (exactArity (fromInteger $2)) } | '__U' inline_prag core_expr { HsUnfold $2 $3 } | '__M' { HsCprInfo } - | '__S' { HsStrictness (HsStrictnessInfo $1) } + | '__S' { HsStrictness (mkStrictnessInfo $1) } | '__C' { HsNoCafRefs } | '__P' qvar_name { HsWorker $2 } inline_prag :: { InlinePragInfo } : {- empty -} { NoInlinePragInfo } - | '[' INTEGER ']' { IMustNotBeINLINEd True (Just (fromInteger $2)) } -- INLINE n - | '[' '!' ']' { IMustNotBeINLINEd True Nothing } -- NOTINLINE - | '[' '!' INTEGER ']' { IMustNotBeINLINEd False (Just (fromInteger $3)) } -- NOINLINE n + | '[' from_prag phase ']' { IMustNotBeINLINEd $2 $3 } + +from_prag :: { Bool } + : {- empty -} { True } + | '!' { False } + +phase :: { Maybe Int } + : {- empty -} { Nothing } + | INTEGER { Just (fromInteger $1) } ------------------------------------------------------- core_expr :: { UfExpr RdrName } @@ -697,14 +759,14 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 } | '__litlit' STRING atype { UfLitLit $2 $3 } - | '__inline_me' core_expr { UfNote UfInlineMe $2 } - | '__inline_call' core_expr { UfNote UfInlineCall $2 } - | '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 } - | scc core_expr { UfNote (UfSCC $1) $2 } | fexpr { $1 } fexpr :: { UfExpr RdrName } fexpr : fexpr core_arg { UfApp $1 $2 } + | scc core_aexpr { UfNote (UfSCC $1) $2 } + | '__inline_me' core_aexpr { UfNote UfInlineMe $2 } + | '__inline_call' core_aexpr { UfNote UfInlineCall $2 } + | '__coerce' atype core_aexpr { UfNote (UfCoerce $2) $3 } | core_aexpr { $1 } core_arg :: { UfExpr RdrName } @@ -718,25 +780,13 @@ core_args :: { [UfExpr RdrName] } core_aexpr :: { UfExpr RdrName } -- Atomic expressions core_aexpr : qvar_name { UfVar $1 } | qdata_name { UfVar $1 } - -- This one means that e.g. "True" will parse as - -- (UfVar True_Id) rather than (UfCon True_Con []). - -- No big deal; it'll be inlined in a jiffy. I tried - -- parsing it to (Con con []) directly, but got bitten - -- when a real constructor Id showed up in an interface - -- file. As usual, a hack bites you in the end. - -- If you want to get a UfCon, then use the - -- curly-bracket notation (True {}). - --- This one is dealt with by qdata_name: see above comments --- | '(' ')' { UfTuple (mkTupConRdrName 0) [] } | core_lit { UfLit $1 } | '(' core_expr ')' { $2 } - -- Tuple construtors are for the *worker* of the tuple - -- Going direct saves needless messing about - | '(' comma_exprs2 ')' { UfTuple (mkRdrNameWkr (mkTupConRdrName (length $2))) $2 } - | '(#' comma_exprs0 '#)' { UfTuple (mkRdrNameWkr (mkUbxTupConRdrName (length $2))) $2 } + | '(' ')' { UfTuple (mkHsTupCon dataName Boxed []) [] } + | '(' comma_exprs2 ')' { UfTuple (mkHsTupCon dataName Boxed $2) $2 } + | '(#' comma_exprs0 '#)' { UfTuple (mkHsTupCon dataName Unboxed $2) $2 } | '{' '__ccall' ccall_string type '}' { let @@ -765,7 +815,7 @@ rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } | core_val_bndr '=' core_expr ';' rec_binds { ($1,$3) : $5 } core_alts :: { [UfAlt RdrName] } - : core_alt { [$1] } + : { [] } | core_alt ';' core_alts { $1 : $3 } core_alt :: { UfAlt RdrName } @@ -775,8 +825,9 @@ core_pat :: { (UfConAlt RdrName, [RdrName]) } core_pat : core_lit { (UfLitAlt $1, []) } | '__litlit' STRING atype { (UfLitLitAlt $2 $3, []) } | qdata_name core_pat_names { (UfDataAlt $1, $2) } - | '(' comma_var_names1 ')' { (UfDataAlt (mkTupConRdrName (length $2)), $2) } - | '(#' comma_var_names1 '#)' { (UfDataAlt (mkUbxTupConRdrName (length $2)), $2) } + | '(' ')' { (UfTupleAlt (mkHsTupCon dataName Boxed []), []) } + | '(' comma_var_names1 ')' { (UfTupleAlt (mkHsTupCon dataName Boxed $2), $2) } + | '(#' comma_var_names1 '#)' { (UfTupleAlt (mkHsTupCon dataName Unboxed $2), $2) } | '__DEFAULT' { (UfDefault, []) } | '(' core_pat ')' { $2 } @@ -860,6 +911,9 @@ cc_caf :: { IsCafCC } src_loc :: { SrcLoc } src_loc : {% getSrcLocP } +-- Check the project version: this makes sure +-- that the project version (e.g. 407) in the interface +-- file is the same as that for the compiler that's reading it checkVersion :: { () } : {-empty-} {% checkVersion Nothing } | INTEGER {% checkVersion (Just (fromInteger $1)) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index ee176e6af0..58adc32f1d 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -9,24 +9,27 @@ module Rename ( renameModule ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrNameHsModule ) +import HsPragmas ( DataPragmas(..) ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation ) import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames ) import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports, - opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations + opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations, + opt_WarnUnusedBinds ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getInterfaceExports, - getImportedRules, loadHomeInterface, getSlurped, removeContext +import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports, + getImportedRules, loadHomeInterface, getSlurped, removeContext, + loadBuiltinRules, getDeferredDecls, ImportDeclResult(..) ) import RnEnv ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupImplicitOccRn, pprAvail, - FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs + lookupImplicitOccsRn, pprAvail, unknownNameErr, + FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, mkSearchPath, moduleName, mkThisModule @@ -34,22 +37,27 @@ import Module ( Module, ModuleName, WhereFrom(..), import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, nameOccName, nameUnique, nameModule, maybeUserImportedFrom, isUserImportedExplicitlyName, isUserImportedName, - maybeWiredInTyConName, maybeWiredInIdName, isWiredInName + maybeWiredInTyConName, maybeWiredInIdName, isWiredInName, + isUserExportedName, toRdrName ) import OccName ( occNameFlavour, isValOcc ) import Id ( idType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet -import PrelMods ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name ) import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) -import PrelInfo ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences ) +import PrelRules ( builtinRules ) +import PrelInfo ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, + ioTyCon_RDR, unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR, + fractionalClassKeys, derivingOccurrences + ) import Type ( namesOfType, funTyCon ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit ) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( Version, initialVersion ) import Bag ( isEmptyBag, bagToList ) import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C ) import UniqSupply ( UniqSupply ) import UniqFM ( lookupUFM ) +import SrcLoc ( noSrcLoc ) import Maybes ( maybeToBool, expectJust ) import Outputable import IO ( openFile, IOMode(..) ) @@ -58,124 +66,138 @@ import IO ( openFile, IOMode(..) ) \begin{code} -renameModule :: UniqSupply - -> RdrNameHsModule - -> IO (Maybe - ( Module - , RenamedHsModule -- Output, after renaming - , InterfaceDetails -- Interface; for interface file generation - , RnNameSupply -- Final env; for renaming derivings - , [ModuleName] -- Imported modules; for profiling - )) - +type RenameResult = ( Module -- This module + , RenamedHsModule -- Renamed module + , Maybe ParsedIface -- The existing interface file, if any + , ParsedIface -- The new interface + , RnNameSupply -- Final env; for renaming derivings + , FixityEnv -- The fixity environment; for derivings + , [ModuleName]) -- Imported modules; for profiling + +renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult) renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc) = -- Initialise the renamer monad - initRn mod_name us (mkSearchPath opt_HiMap) loc - (rename this_mod) >>= - \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) -> + do { + ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) + <- initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) ; -- Check for warnings - printErrorsAndWarnings rn_errs_bag rn_warns_bag >> + printErrorsAndWarnings rn_errs_bag rn_warns_bag ; -- Dump any debugging output - dump_action >> + dump_action ; -- Return results - if not (isEmptyBag rn_errs_bag) then - ghcExit 1 >> return Nothing - else + if not (isEmptyBag rn_errs_bag) then + do { ghcExit 1 ; return Nothing } + else return maybe_rn_stuff + } \end{code} - \begin{code} -rename :: RdrNameHsModule - -> RnMG (Maybe (Module, RenamedHsModule, InterfaceDetails, RnNameSupply, [ModuleName]), IO ()) -rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc) +rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ()) +rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> -- CHECK FOR EARLY EXIT - if not (maybeToBool maybe_stuff) then - -- Everything is up to date; no need to recompile further - rnDump [] [] `thenRn` \ dump_action -> - returnRn (Nothing, dump_action) - else - let - Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff - ExportEnv export_avails _ _ = export_env - in + case maybe_stuff of { + Nothing -> -- Everything is up to date; no need to recompile further + rnDump [] [] `thenRn` \ dump_action -> + returnRn (Nothing, dump_action) ; + + Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface) -> + + -- DEAL WITH DEPRECATIONS + rnDeprecs local_gbl_env mod_deprec local_decls `thenRn` \ my_deprecs -> + + -- DEAL WITH LOCAL FIXITIES + fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> -- RENAME THE SOURCE - initRnMS gbl_env fixity_env SourceMode ( + initRnMS gbl_env local_fixity_env SourceMode ( rnSourceDecls local_decls ) `thenRn` \ (rn_local_decls, source_fvs) -> -- SLURP IN ALL THE NEEDED DECLARATIONS implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> let - real_source_fvs = implicit_fvs `plusFV` source_fvs `plusFV` export_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - -- The export_fvs make the exported names look just as if they -- occurred in the source program. For the reasoning, see the - -- comments with RnIfaces.getImportVersions - export_fvs = mkNameSet (map availName export_avails) - in - slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> - let - rn_all_decls = rn_local_decls ++ rn_imp_decls + -- comments with RnIfaces.getImportVersions. + -- We only need the 'parent name' of the avail; + -- that's enough to suck in the declaration. + export_fvs = mkNameSet (map availName export_avails) + real_source_fvs = source_fvs `plusFV` export_fvs - -- COLLECT ALL DEPRECATIONS - deprec_sigs = [ ds | ValD bnds <- rn_local_decls, ds <- collectDeprecs bnds ] - deprecs = case mod_deprec of - Nothing -> deprec_sigs - Just txt -> Deprecation (IEModuleContents undefined) txt : deprec_sigs + slurp_fvs = implicit_fvs `plusFV` real_source_fvs + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. in + loadBuiltinRules builtinRules `thenRn_` + slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND + rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action -> checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now - rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> returnRn (Nothing, dump_action) else -- GENERATE THE VERSION/USAGE INFO - getImportVersions mod_name export_env `thenRn` \ my_usages -> - getNameSupplyRn `thenRn` \ name_supply -> + mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) -> -- RETURN THE RENAMED MODULE + getNameSupplyRn `thenRn` \ name_supply -> let - has_orphans = any isOrphanDecl rn_local_decls + this_module = mkThisModule mod_name direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] + + -- Export only those fixities that are for names that are + -- (a) defined in this module + -- (b) exported + exported_fixities + = [ FixitySig (toRdrName name) fixity loc + | FixitySig name fixity loc <- nameEnvElts local_fixity_env, + isUserExportedName name + ] + + new_iface = ParsedIface { pi_mod = this_module + , pi_vers = initialVersion + , pi_orphan = any isOrphanDecl rn_local_decls + , pi_exports = my_exports + , pi_usages = my_usages + , pi_fixity = (initialVersion, exported_fixities) + , pi_deprecs = my_deprecs + -- These ones get filled in later + , pi_insts = [], pi_decls = [] + , pi_rules = (initialVersion, []) + } + renamed_module = HsModule mod_name vers trashed_exports trashed_imports - rn_all_decls + (rn_local_decls ++ rn_imp_decls) mod_deprec loc + + result = (this_module, renamed_module, + old_iface, new_iface, + name_supply, local_fixity_env, + direct_import_mods) in + -- REPORT UNUSED NAMES, AND DEBUG DUMP reportUnusedNames mod_name direct_import_mods gbl_env global_avail_env - export_env - source_fvs `thenRn_` - rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> - - returnRn (Just (mkThisModule mod_name, - renamed_module, - (InterfaceDetails has_orphans my_usages export_env deprecs), - name_supply, - direct_import_mods), dump_action) + export_avails source_fvs `thenRn_` + + returnRn (Just result, dump_action) } where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] - - collectDeprecs EmptyBinds = [] - collectDeprecs (ThenBinds x y) = collectDeprecs x ++ collectDeprecs y - collectDeprecs (MonoBind _ sigs _) = [ d | DeprecSig d _ <- sigs ] \end{code} @implicitFVs@ forces the renamer to slurp in some things which aren't @@ -183,11 +205,9 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} implicitFVs mod_name decls - = mapRn lookupImplicitOccRn implicit_occs `thenRn` \ implicit_names -> - returnRn (implicit_main `plusFV` - mkNameSet (map getName default_tycons) `plusFV` - mkNameSet thinAirIdNames `plusFV` - mkNameSet implicit_names) + = lookupImplicitOccsRn implicit_occs `thenRn` \ implicit_names -> + returnRn (mkNameSet (map getName default_tycons) `plusFV` + implicit_names) where -- Add occurrences for Int, and (), because they -- are the types to which ambigious type variables may be defaulted by @@ -201,15 +221,18 @@ implicitFVs mod_name decls -- Add occurrences for IO or PrimIO implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME - | otherwise = emptyFVs + || mod_name == pREL_MAIN_Name = [ioTyCon_RDR] + | otherwise = [] -- Now add extra "occurrences" for things that -- the deriving mechanism, or defaulting, will later need in order to -- generate code - implicit_occs = foldr ((++) . get) [] decls + implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls + + -- Virtually every program has error messages in it somewhere + string_occs = [unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR] - get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _)) + get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _)) = concat (map get_deriv deriv_classes) get other = [] @@ -226,7 +249,7 @@ isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) -- The decl is an orphan if Baz and T are both not locally defined, -- even if Foo *is* locally defined -isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) +isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _)) = check lhs where -- At the moment we just check for common LHS forms @@ -273,8 +296,13 @@ slurpImpDecls source_fvs getSlurped `thenRn` \ source_binders -> slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> - -- And finally get everything else - closeDecls decls needed + -- Then get everything else + closeDecls decls needed `thenRn` \ decls1 -> + + -- Finally, get any deferred data type decls + slurpDeferredDecls decls1 `thenRn` \ final_decls -> + + returnRn final_decls ------------------------------------------------------- slurpSourceRefs :: NameSet -- Variables defined in source @@ -309,7 +337,7 @@ slurpSourceRefs source_binders source_fvs go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - go_inner decls fvs emptyFVs refs `thenRn` \ (decls1, fvs1, gates1) -> + foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> go_outer decls2 fvs2 (all_gates `plusFV` gates2) @@ -317,39 +345,17 @@ slurpSourceRefs source_binders source_fvs -- Knock out the all_gates because even if we don't slurp any new -- decls we can get some apparently-new gates from wired-in names - go_inner decls fvs gates [] - = returnRn (decls, fvs, gates) - - go_inner decls fvs gates (wanted_name:refs) - | isWiredInName wanted_name - = load_home wanted_name `thenRn_` - go_inner decls fvs (gates `plusFV` getWiredInGates wanted_name) refs - - | otherwise - = importDecl wanted_name `thenRn` \ maybe_decl -> - case maybe_decl of - Nothing -> go_inner decls fvs gates refs -- No declaration... (already slurped, or local) - Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - go_inner (new_decl : decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` getGates source_fvs new_decl) - refs - - -- When we find a wired-in name we must load its - -- home module so that we find any instance decls therein - load_home name - | name `elemNameSet` source_binders = returnRn () - -- When compiling the prelude, a wired-in thing may - -- be defined in this module, in which case we don't - -- want to load its home module! - -- Using 'isLocallyDefined' doesn't work because some of - -- the free variables returned are simply 'listTyCon_Name', - -- with a system provenance. We could look them up every time - -- but that seems a waste. - | otherwise = loadHomeInterface doc name `thenRn_` - returnRn () - where - doc = ptext SLIT("need home module for wired in thing") <+> ppr name + go_inner (decls, fvs, gates) wanted_name + = importDecl wanted_name `thenRn` \ import_result -> + case import_result of + AlreadySlurped -> returnRn (decls, fvs, gates) + WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name) + Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor + + HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (new_decl : decls, + fvs1 `plusFV` fvs, + gates `plusFV` getGates source_fvs new_decl) rnInstDecls decls fvs gates [] = returnRn (decls, fvs, gates) @@ -379,17 +385,6 @@ closeDecls decls needed ------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) - - -------------------------------------------------------- -- Augment decls with any decls needed by needed. -- Return also free vars of the new decls (only) slurpDecls decls needed @@ -401,14 +396,66 @@ slurpDecls decls needed ------------------------------------------------------- slurpDecl decls fvs wanted_name - = importDecl wanted_name `thenRn` \ maybe_decl -> - case maybe_decl of - -- No declaration... (wired in thing) - Nothing -> returnRn (decls, fvs) - + = importDecl wanted_name `thenRn` \ import_result -> + case import_result of -- Found a declaration... rename it - Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl:decls, fvs1 `plusFV` fvs) + HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (new_decl:decls, fvs1 `plusFV` fvs) + + -- No declaration... (wired in thing, or deferred, or already slurped) + other -> returnRn (decls, fvs) + + +------------------------------------------------------- +rnIfaceDecls :: [RenamedHsDecl] -> FreeVars + -> [(Module, RdrNameHsDecl)] + -> RnM d ([RenamedHsDecl], FreeVars) +rnIfaceDecls decls fvs [] = returnRn (decls, fvs) +rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> + rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds + +rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) +\end{code} + + +%********************************************************* +%* * +\subsection{Deferred declarations} +%* * +%********************************************************* + +The idea of deferred declarations is this. Suppose we have a function + f :: T -> Int + data T = T1 A | T2 B + data A = A1 X | A2 Y + data B = B1 P | B2 Q +Then we don't want to load T and all its constructors, and all +the types those constructors refer to, and all the types *those* +constructors refer to, and so on. That might mean loading many more +interface files than is really necessary. So we 'defer' loading T. + +But f might be strict, and the calling convention for evaluating +values of type T depends on how many constructors T has, so +we do need to load T, but not the full details of the type T. +So we load the full decl for T, but only skeleton decls for A and B: + f :: T -> Int + data T = {- 2 constructors -} + +Whether all this is worth it is moot. + +\begin{code} +slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] +slurpDeferredDecls decls + = getDeferredDecls `thenRn` \ def_decls -> + rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> + ASSERT( isEmptyFVs fvs ) + returnRn decls1 + +stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc)) + = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc)) + -- Nuke the context and constructors + -- But retain the *number* of constructors! + -- Also the tvs will have kinds on them. \end{code} @@ -461,7 +508,7 @@ getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) (map getTyVarName tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (map getTyVarName tvs) `addOneToNameSet` tycon @@ -525,6 +572,81 @@ getInstDeclGates other = emptyFVs %********************************************************* %* * +\subsection{Fixities} +%* * +%********************************************************* + +\begin{code} +fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv +fixitiesFromLocalDecls gbl_env decls + = foldlRn getFixities emptyNameEnv decls `thenRn` \ env -> + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_` + returnRn env + where + getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv + getFixities acc (FixD fix) + = fix_decl acc fix + + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) + = foldlRn fix_decl acc [sig | FixSig sig <- sigs] + -- Get fixities from class decl sigs too. + getFixities acc other_decl + = returnRn acc + + fix_decl acc sig@(FixitySig rdr_name fixity loc) + = -- Check for fixity decl for something not declared + case lookupRdrEnv gbl_env rdr_name of { + Nothing | opt_WarnUnusedBinds + -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) + `thenRn_` returnRn acc + | otherwise -> returnRn acc ; + + Just (name:_) -> + + -- Check for duplicate fixity decl + case lookupNameEnv acc name of { + Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') + `thenRn_` returnRn acc ; + + Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) + }} +\end{code} + + +%********************************************************* +%* * +\subsection{Deprecations} +%* * +%********************************************************* + +For deprecations, all we do is check that the names are in scope. +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. + +\begin{code} +rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt + -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation] +rnDeprecs gbl_env mod_deprec decls + = mapRn rn_deprec deprecs `thenRn_` + returnRn (extra_deprec ++ deprecs) + where + deprecs = [d | DeprecD d <- decls] + extra_deprec = case mod_deprec of + Nothing -> [] + Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc] + + rn_deprec (Deprecation ie txt loc) + = pushSrcLocRn loc $ + mapRn check (ieNames ie) + + check n = case lookupRdrEnv gbl_env n of + Nothing -> addErrRn (unknownNameErr n) + Just _ -> returnRn () +\end{code} + + +%********************************************************* +%* * \subsection{Unused names} %* * %********************************************************* @@ -532,10 +654,10 @@ getInstDeclGates other = emptyFVs \begin{code} reportUnusedNames :: ModuleName -> [ModuleName] -> GlobalRdrEnv -> AvailEnv - -> ExportEnv -> NameSet -> RnMG () + -> Avails -> NameSet -> RnMG () reportUnusedNames mod_name direct_import_mods gbl_env avail_env - (ExportEnv export_avails _ _) mentioned_names + export_avails mentioned_names = let used_names = mentioned_names `unionNameSets` availsToNameSet export_avails @@ -647,25 +769,18 @@ printMinimalImports mod_name imps other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ returnRn (IEVar n) -warnDeprec :: (Name, DeprecTxt) -> RnM d () -warnDeprec (name, txt) - = pushSrcLocRn (getSrcLoc name) $ - addWarnRn $ - sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+> - text "is deprecated:", nest 4 (ppr txt) ] - - rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [RenamedHsDecl] -- Renamed local decls -> RnMG (IO ()) -rnDump imp_decls decls +rnDump imp_decls local_decls | opt_D_dump_rn_trace || opt_D_dump_rn_stats || opt_D_dump_rn = getRnStats imp_decls `thenRn` \ stats_msg -> returnRn (printErrs stats_msg >> - dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls))) + dumpIfSet opt_D_dump_rn "Renamer:" + (vcat (map ppr (local_decls ++ imp_decls)))) | otherwise = returnRn (return ()) \end{code} @@ -682,7 +797,7 @@ getRnStats :: [RenamedHsDecl] -> RnMG SDoc getRnStats imported_decls = getIfacesRn `thenRn` \ ifaces -> let - n_mods = length [() | (_, _, _, Just _) <- eltsFM (iImpModInfo ifaces)] + n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), -- Data, newtype, and class decls are in the decls_fm @@ -735,3 +850,27 @@ count_decls decls inst_decls = length [() | InstD _ <- decls] \end{code} + +%************************************************************************ +%* * +\subsection{Errors and warnings} +%* * +%************************************************************************ + +\begin{code} +warnDeprec :: (Name, DeprecTxt) -> RnM d () +warnDeprec (name, txt) + = pushSrcLocRn (getSrcLoc name) $ + addWarnRn $ + sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+> + text "is deprecated:", nest 4 (ppr txt) ] + + +unusedFixityDecl rdr_name fixity + = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] + +dupFixityDecl rdr_name loc1 loc2 + = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext SLIT("at ") <+> ppr loc1, + ptext SLIT("and") <+> ppr loc2] +\end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index ff10456d0e..17284cedc3 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -21,12 +21,13 @@ module RnBinds ( import {-# SOURCE #-} RnSource ( rnHsSigType ) import HsSyn -import HsBinds ( sigsForMe, cmpHsSig, sigName, hsSigDoc ) +import HsBinds ( eqHsSig, sigName, hsSigDoc ) import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupOccRn, +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, + lookupGlobalOccRn, lookupOccRn, lookupSigOccRn, warnUnusedLocalBinds, mapFvRn, FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, unknownNameErr @@ -172,11 +173,14 @@ rnTopMonoBinds EmptyMonoBinds sigs = returnRn (EmptyBinds, emptyFVs) rnTopMonoBinds mbinds sigs - = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> - renameSigs (okBindSig (mkNameSet binder_names)) sigs `thenRn` \ (siglist, sig_fvs) -> + = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> + let + bndr_name_set = mkNameSet binder_names + in + renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> let type_sig_vars = [n | Sig n _ _ <- siglist] - un_sigd_binders | opt_WarnMissingSigs = binder_names `minusList` type_sig_vars + un_sigd_binders | opt_WarnMissingSigs = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars) | otherwise = [] in mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` @@ -317,8 +321,8 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) -- Find which things are bound in this group let names_bound_here = mkNameSet (collectPatBinders pat') - sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs in + sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> rnGRHSs grhss `thenRn` \ (grhss', fvs) -> returnRn [(names_bound_here, @@ -331,8 +335,9 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ lookupBndrRn name `thenRn` \ new_name -> let - sigs_for_me = sigsForMe (new_name ==) sigs + names_bound_here = unitNameSet new_name in + sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` returnRn @@ -341,6 +346,15 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) FunMonoBind new_name inf new_matches locn, sigs_for_me )] + + +sigsForMe names_bound_here sigs + = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs) + where + check sigs sig = case filter (eqHsSig sig) sigs of + [] -> returnRn (sig:sigs) + other -> dupSigDeclErr sig `thenRn_` + returnRn sigs \end{code} @@ -477,14 +491,12 @@ renameSigs ok_sig sigs is_in_scope sig = case sigName sig of Just n -> not (isUnboundName n) Nothing -> True - (not_dups, dups) = removeDups cmpHsSig in_scope - (goods, bads) = partition ok_sig not_dups + (goods, bads) = partition ok_sig in_scope in mapRn_ unknownSigErr bads `thenRn_` - mapRn_ dupSigDeclErr dups `thenRn_` returnRn (goods, fvs) --- We use lookupOccRn in the signatures, which is a little bit unsatisfactory +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} @@ -497,7 +509,7 @@ renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars) renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) @@ -508,28 +520,23 @@ renameSig (SpecInstSig ty src_loc) renameSig (SpecSig v ty src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) renameSig (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) -renameSig (DeprecSig (Deprecation ie txt) src_loc) - = pushSrcLocRn src_loc $ - renameIE lookupOccRn ie `thenRn` \ (new_ie, fvs) -> - returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs) - renameSig (InlineSig v p src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> returnRn (InlineSig new_v p src_loc, unitFV new_v) renameSig (NoInlineSig v p src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> returnRn (NoInlineSig new_v p src_loc, unitFV new_v) \end{code} @@ -564,7 +571,7 @@ renameIE lookup_occ_nm (IEModuleContents m) %************************************************************************ \begin{code} -dupSigDeclErr (sig:sigs) +dupSigDeclErr sig = pushSrcLocRn loc $ addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, ppr sig]) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 25e895fc63..05ec12accc 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -22,10 +22,9 @@ import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, - mkIPName, isSystemName, isWiredInName, + mkIPName, isWiredInName, hasBetterProv, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, - occNameUserString, setNameProvenance, getNameProvenance, pprNameProvenance ) import NameSet @@ -33,7 +32,7 @@ import OccName ( OccName, mkDFunOcc, occNameUserString, occNameString, occNameFlavour ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) +import TysWiredIn ( listTyCon ) import Type ( funTyCon ) import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName ) import TyCon ( TyCon ) @@ -42,7 +41,7 @@ import Unique ( Unique, Uniquable(..) ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups, equivClasses, thenCmp ) +import Util ( removeDups, equivClasses, thenCmp, sortLt ) import List ( nub ) \end{code} @@ -55,63 +54,58 @@ import List ( nub ) %********************************************************* \begin{code} -newLocalTopBinder :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM d Name -newLocalTopBinder mod occ rec_exp_fn loc - = newTopBinder mod occ (\name -> setNameProvenance name (LocalDef loc (rec_exp_fn name))) - -- We must set the provenance of the thing in the cache - -- correctly, particularly whether or not it is locally defined. - -- - -- Since newLocalTopBinder is used only - -- at binding occurrences, we may as well get the provenance - -- dead right first time; hence the rec_exp_fn passed in - -newImportedBinder :: Module -> RdrName -> RnM d Name -newImportedBinder mod rdr_name - = ASSERT2( isUnqual rdr_name, ppr rdr_name ) - newTopBinder mod (rdrNameOcc rdr_name) (\name -> name) - -- Provenance is already implicitImportProvenance - implicitImportProvenance = NonLocalDef ImplicitImport False -newTopBinder :: Module -> OccName -> (Name -> Name) -> RnM d Name -newTopBinder mod occ set_prov +newTopBinder :: Module -> OccName -> RnM d Name +newTopBinder mod occ = -- First check the cache + traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_` + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (moduleName mod, occ) in case lookupFM cache key of - -- A hit in the cache! - -- Set the Module of the thing, and set its provenance (hack pending - -- spj update) + -- A hit in the cache! We are at the binding site of the name, which is + -- the time we know all about the Name's host Module (in particular, which + -- package it comes from), so update the Module in the name. + -- But otherwise *leave the Provenance alone*: -- - -- It also means that if there are two defns for the same thing - -- in a module, then each gets a separate SrcLoc + -- * For imported names, the Provenance may already be correct. + -- e.g. We imported Prelude.hi, and set the provenance of PrelShow.Show + -- to 'UserImport from Prelude'. Note that we havn't yet opened PrelShow.hi + -- Later we find we really need PrelShow.Show, so we open PrelShow.hi, and + -- that's when we find the binding occurrence of Show. -- - -- There's a complication for wired-in names. We don't want to + -- * For locally defined names, we do a setProvenance on the Name + -- right after newTopBinder, and then use updateProveances to finally + -- set the provenances in the cache correctly. + -- + -- NB: for wired-in names it's important not to -- forget that they are wired in even when compiling that module -- (else we spit out redundant defns into the interface file) - -- So for them we just set the provenance Just name -> let - new_name = set_prov (setNameModule name mod) + new_name = setNameModule name mod new_cache = addToFM cache key new_name in setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` + traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! -- Build a completely new Name, and put it in the cache + -- Even for locally-defined names we use implicitImportProvenance; + -- updateProvenances will set it to rights Nothing -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - new_name = set_prov (mkGlobalName uniq mod occ implicitImportProvenance) + new_name = mkGlobalName uniq mod occ implicitImportProvenance new_cache = addToFM cache key new_name in setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -136,8 +130,10 @@ mkImportedGlobalName mod_name occ key = (mod_name, occ) in case lookupFM cache key of - Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + Just name -> traceRn (text "mkImportedGlobalName: hit" <+> ppr name) `thenRn_` + returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + traceRn (text "mkImportedGlobalName: new" <+> ppr name) `thenRn_` returnRn name where (us', us1) = splitUniqSupply us @@ -175,7 +171,6 @@ updateProvenances names = setNameProvenance name_in_cache (getNameProvenance name_with_prov) - mkImportedGlobalFromRdrName :: RdrName -> RnM d Name mkImportedGlobalFromRdrName rdr_name | isQual rdr_name @@ -209,13 +204,16 @@ getIPName rdr_name %* * %********************************************************* -@newImplicitBinder@ is used for (a) dfuns -(b) default methods, defined in this module. +@newImplicitBinder@ is used for + (a) dfuns (RnSource.rnDecl on InstDecls) + (b) default methods (RnSource.rnDecl on ClassDecls) +when these dfuns/default methods are defined in the module being compiled \begin{code} newImplicitBinder occ src_loc = getModuleRn `thenRn` \ mod_name -> - newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc + newTopBinder (mkThisModule mod_name) occ `thenRn` \ name -> + returnRn (setNameProvenance name (LocalDef src_loc Exported)) \end{code} Make a name for the dict fun for an instance decl @@ -232,16 +230,15 @@ newDFunName key@(cl_occ, tycon_occ) loc \begin{code} getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names -getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty -getDFunKey (MonoFunTy _ ty) = getDFunKey ty -getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) - -get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) -get_tycon_key (MonoTyApp ty _) = get_tycon_key ty -get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) -get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) -get_tycon_key (MonoListTy _) = getOccName listTyCon -get_tycon_key (MonoFunTy _ _) = getOccName funTyCon +getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty +getDFunKey (HsFunTy _ ty) = getDFunKey ty +getDFunKey (HsPredTy (HsPClass cls (ty:_))) = (nameOccName cls, get_tycon_key ty) + +get_tycon_key (HsTyVar tv) = getOccName tv +get_tycon_key (HsAppTy ty _) = get_tycon_key ty +get_tycon_key (HsTupleTy (HsTupCon n _) tys) = getOccName n +get_tycon_key (HsListTy _) = getOccName listTyCon +get_tycon_key (HsFunTy _ _) = getOccName funTyCon \end{code} @@ -351,7 +348,7 @@ bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVa bindUVarRn = bindLocalRn ------------------------------------- -extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope = getLocalNameEnv `thenRn` \ env -> @@ -364,16 +361,16 @@ extendTyVarEnvFVRn tyvars enclosed_scope setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs tyvar_names) -bindTyVarsRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS a) +bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVarsRn doc_str tyvar_names enclosed_scope = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> enclosed_scope tyvars -- Gruesome name: return Names as well as HsTyVars -bindTyVars2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS a) +bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName] + -> ([Name] -> [HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> @@ -383,16 +380,16 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope names (zipWith replaceTyVarName tyvar_names names) -bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS (a, FreeVars)) +bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) bindTyVarsFVRn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope tyvars `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) -bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars)) +bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName] + -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) bindTyVarsFV2Rn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> @@ -431,7 +428,8 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> + = traceRn (text "lookupBndrRn" <+> ppr rdr_name) `thenRn_` + getNameEnvs `thenRn` \ (global_env, local_env) -> -- Try local env case lookupRdrEnv local_env rdr_name of { @@ -441,7 +439,9 @@ lookupBndrRn rdr_name getModeRn `thenRn` \ mode -> case mode of InterfaceMode -> -- Look in the global name cache - mkImportedGlobalFromRdrName rdr_name + mkImportedGlobalFromRdrName rdr_name `thenRn` \ n -> + traceRn (text "lookupBndrRn result:" <+> ppr n) `thenRn_` + returnRn n SourceMode -> -- Source mode, so look up a *qualified* version -- of the name, so that we get the right one even @@ -454,10 +454,7 @@ lookupBndrRn rdr_name Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name) } --- Just like lookupRn except that we record the occurrence too --- Perhaps surprisingly, even wired-in names are recorded. --- Why? So that we know which wired-in names are referred to when --- deciding which instance declarations to import. +-- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name = getNameEnvs `thenRn` \ (global_env, local_env) -> @@ -472,6 +469,45 @@ lookupGlobalOccRn rdr_name = getNameEnvs `thenRn` \ (global_env, local_env) -> lookup_global_occ global_env rdr_name +-- lookupSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- In a sense, it's clear that the 'f' in the signature must refer +-- to A.f, but the Haskell98 report does not stipulate this, so +-- I treat the 'f' in the signature as a reference to an unqualified +-- 'f' and hence fail with an ambiguous reference. +lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn = lookupOccRn + +{- OLD VERSION +-- This code tries to be cleverer than the above. +-- The variable in a signature must refer to a locally-defined thing, +-- even if there's an imported thing of the same name. +-- +-- But this doesn't work for instance decls: +-- instance Enum Int where +-- {-# INLINE enumFrom #-} +-- ... +-- Here the enumFrom is an imported reference! +lookupSigOccRn rdr_name + = getNameEnvs `thenRn` \ (global_env, local_env) -> + case (lookupRdrEnv local_env rdr_name, lookupRdrEnv global_env rdr_name) of + (Just name, _) -> returnRn name + + (Nothing, Just names) -> case filter isLocallyDefined names of + [n] -> returnRn n + ns -> pprPanic "lookupSigOccRn" (ppr rdr_name <+> ppr names <+> ppr ns) + -- There can't be a local top-level name-clash + -- (That's dealt with elsewhere.) + + (Nothing, Nothing) -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) +-} + + -- Look in both local and global env lookup_occ global_env local_env rdr_name = case lookupRdrEnv local_env rdr_name of @@ -517,6 +553,11 @@ The name cache should have the correct provenance, though. \begin{code} lookupImplicitOccRn :: RdrName -> RnM d Name lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name + +lookupImplicitOccsRn :: [RdrName] -> RnM d NameSet +lookupImplicitOccsRn rdr_names + = mapRn lookupImplicitOccRn rdr_names `thenRn` \ names -> + returnRn (mkNameSet names) \end{code} @unQualInScope@ returns a function that takes a @Name@ and tells whether @@ -561,19 +602,9 @@ combine_globals ns_old ns_new -- ns_new is often short add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates | otherwise = n:ns where - choose n' | n==n' && better_provenance n n' = n - | otherwise = n' - --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- an explicitly-imported thing over an implicitly imported thing -better_provenance n1 n2 - = case (getNameProvenance n1, getNameProvenance n2) of - (LocalDef _ _, _ ) -> True - (NonLocalDef (UserImport _ _ True) _, _ ) -> True - (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True - other -> False + choose m | n==m && n `hasBetterProv` m = n + | otherwise = m + is_duplicate :: Name -> Name -> Bool is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False @@ -621,11 +652,11 @@ addAvailToNameSet names avail = addListToNameSet names (availNames avail) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails -availName :: AvailInfo -> Name +availName :: GenAvailInfo name -> name availName (Avail n) = n availName (AvailTC n _) = n -availNames :: AvailInfo -> [Name] +availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns @@ -633,6 +664,12 @@ addSysAvails :: AvailInfo -> [Name] -> AvailInfo addSysAvails avail [] = avail addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) +rdrAvailInfo :: AvailInfo -> RdrAvailInfo +-- Used when building the avails we are going to put in an interface file +-- We sort the components to reduce needless wobbling of interfaces +rdrAvailInfo (Avail n) = Avail (nameOccName n) +rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns)) + filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 8669ca64e6..7bfa409821 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -18,21 +18,22 @@ module RnExpr ( #include "HsVersions.h" import {-# SOURCE #-} RnBinds ( rnBinds ) -import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType ) +import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import RnIfaces ( lookupFixity ) +import RnIfaces ( lookupFixityRn ) import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence ) import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR + ioDataCon_RDR, addr2Integer_RDR, + foldr_RDR, build_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon @@ -44,7 +45,7 @@ import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet, UniqSet ) -import Unique ( assertIdKey ) +import Unique ( hasKey, assertIdKey ) import Util ( removeDups ) import ListSetOps ( unionLists ) import Maybes ( maybeToBool ) @@ -70,7 +71,7 @@ rnPat (VarPatIn name) rnPat (SigPatIn pat ty) | opt_GlasgowExts = rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsPolyType doc ty `thenRn` \ (ty', fvs2) -> + rnHsType doc ty `thenRn` \ (ty', fvs2) -> returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) | otherwise @@ -107,7 +108,7 @@ rnPat (ConOpPatIn pat1 con _ pat2) -- See comments with rnExpr (OpApp ...) (case mode of InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2') - SourceMode -> lookupFixity con' `thenRn` \ fixity -> + SourceMode -> lookupFixityRn con' `thenRn` \ fixity -> mkConOpPatRn pat1' con' fixity pat2' ) `thenRn` \ pat' -> returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') @@ -191,7 +192,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) -> + Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) -> returnRn (Just ty', ty_fvs) | otherwise -> addErrRn (patSigErr ty) `thenRn_` returnRn (Nothing, emptyFVs) @@ -276,7 +277,7 @@ rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) rnExpr (HsVar v) = lookupOccRn v `thenRn` \ name -> - if nameUnique name == assertIdKey then + if name `hasKey` assertIdKey then -- We expand it to (GHCerr.assert__ location) mkAssertExpr else @@ -312,7 +313,7 @@ rnExpr (OpApp e1 op _ e2) -- Don't even look up the fixity when in interface mode getModeRn `thenRn` \ mode -> (case mode of - SourceMode -> lookupFixity op_name `thenRn` \ fixity -> + SourceMode -> lookupFixityRn op_name `thenRn` \ fixity -> mkOpAppRn e1' op' fixity e2' InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2') ) `thenRn` \ final_e -> @@ -350,12 +351,12 @@ rnExpr section@(SectionR op expr) rnExpr (HsCCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> - lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr -> - lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io -> + = lookupImplicitOccsRn [ccallableClass_RDR, + creturnableClass_RDR, + ioDataCon_RDR] `thenRn` \ implicit_fvs -> rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, - fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io) + fvs_args `plusFV` implicit_fvs) rnExpr (HsSCC lbl expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> @@ -379,7 +380,7 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupImplicitOccRn monadClass_RDR `thenRn` \ monad -> + lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs -> rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> -- check the statement list ends in an expression case last stmts' of { @@ -387,17 +388,23 @@ rnExpr e@(HsDo do_or_lc stmts src_loc) ReturnStmt _ -> returnRn () ; -- for list comprehensions _ -> addErrRn (doStmtListErr e) } `thenRn_` - returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad) + returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) + where + implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR] + -- Monad stuff should not be necessary for a list comprehension + -- but the typechecker looks up the bind and return Ids anyway + -- Oh well. + rnExpr (ExplicitList exps) = rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name) -rnExpr (ExplicitTuple exps boxed) +rnExpr (ExplicitTuple exps boxity) = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name) + returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) where - tycon_name = tupleTyCon_name boxed (length exps) + tycon_name = tupleTyCon_name boxity (length exps) rnExpr (RecordCon con_id rbinds) = lookupOccRn con_id `thenRn` \ conname -> @@ -722,8 +729,8 @@ checkPrecMatch True op (Match _ (p1:p2:_) _ _) checkPrecMatch True op _ = panic "checkPrecMatch" checkPrec op (ConOpPatIn _ op1 _ _) right - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> + = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -737,7 +744,7 @@ checkPrec op (ConOpPatIn _ op1 _ _) right checkRn inf_ok (precParseErr infol infor) checkPrec op (NegPatIn _) right - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix)) checkPrec op pat right @@ -754,7 +761,7 @@ checkSectionPrec left_or_right section op arg where HsVar op_name = op go_for_it pp_arg_op arg_fix@(Fixity arg_prec _) - = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) -> + = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) -> checkRn (op_prec < arg_prec) (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section) \end{code} @@ -808,13 +815,11 @@ litOccurrence (HsStringPrim _) = returnRn (unitFV (getName addrPrimTyCon)) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR `thenRn` \ num -> - returnRn (unitFV num) -- Int and Integer are forced in by Num + = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR] + -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac -> - lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio -> - returnRn (unitFV frac `plusFV` unitFV ratio) + = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR] -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 58d71289f0..60dfedb452 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,10 +11,10 @@ module RnHsSyn where import HsSyn import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, - listTyCon, charTyCon ) +import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) import Name ( Name, getName ) import NameSet +import BasicTypes ( Boxity ) import Util import Outputable \end{code} @@ -45,7 +45,7 @@ type RenamedRecordBinds = HsRecordBinds Name RenamedPat type RenamedSig = Sig Name type RenamedStmt = Stmt Name RenamedPat type RenamedFixitySig = FixitySig Name -type RenamedDeprecation = Deprecation Name +type RenamedDeprecation = DeprecDecl Name type RenamedClassOpPragmas = ClassOpPragmas Name type RenamedClassPragmas = ClassPragmas Name @@ -67,27 +67,25 @@ charTyCon_name, listTyCon_name :: Name charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon -tupleTyCon_name :: Bool -> Int -> Name -tupleTyCon_name True n = getName (tupleTyCon n) -tupleTyCon_name False n = getName (unboxedTupleTyCon n) +tupleTyCon_name :: Boxity -> Int -> Name +tupleTyCon_name boxity n = getName (tupleTyCon boxity n) extractHsTyNames :: RenamedHsType -> NameSet extractHsTyNames ty = get ty where - get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (MonoListTy ty) = unitNameSet listTyCon_name + get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 + get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty - get (MonoTupleTy tys boxed) = unitNameSet (tupleTyCon_name boxed (length tys)) - `unionNameSets` extractHsTyNames_s tys - get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (MonoIParamTy n ty) = get ty - get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys - get (MonoUsgForAllTy uv ty) = get ty - get (MonoUsgTy u ty) = get ty - get (MonoTyVar tv) = unitNameSet tv + get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n + `unionNameSets` extractHsTyNames_s tys + get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 + get (HsPredTy p) = extractHsPredTyNames p + get (HsUsgForAllTy uv ty) = get ty + get (HsUsgTy u ty) = get ty + get (HsTyVar tv) = unitNameSet tv get (HsForAllTy (Just tvs) - ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) + ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` mkNameSet (map getTyVarName tvs) get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 0b6c36894a..71221cee80 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,13 +5,15 @@ \begin{code} module RnIfaces ( - getInterfaceExports, + findAndReadIface, + + getInterfaceExports, getDeferredDecls, getImportedInstDecls, getImportedRules, - lookupFixity, loadHomeInterface, - importDecl, recordSlurp, - getImportVersions, getSlurped, + lookupFixityRn, loadHomeInterface, + importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules, + mkImportExportInfo, getSlurped, - checkUpToDate, + checkModUsage, outOfDate, upToDate, getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else @@ -19,20 +21,23 @@ module RnIfaces ( #include "HsVersions.h" -import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), ForeignDecl(..), ForKind(..), isDynamicExtName, FixitySig(..), RuleDecl(..), - isClassOpSig, Deprecation(..) + isClassOpSig, DeprecDecl(..) ) +import HsImpExp ( ieNames ) +import CoreSyn ( CoreRule ) import BasicTypes ( Version, NewOrData(..), defaultFixity ) import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleDecl, - extractHsTyRdrNames, RdrNameDeprecation + RdrNameFixitySig, RdrNameDeprecation, RdrNameIE, + extractHsTyRdrNames ) -import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName, +import RnEnv ( mkImportedGlobalName, newTopBinder, mkImportedGlobalFromRdrName, lookupOccRn, lookupImplicitOccRn, - pprAvail, + pprAvail, rdrAvailInfo, availName, availNames, addAvailToNameSet, addSysAvails, FreeVars, emptyFVs ) @@ -40,12 +45,8 @@ import RnMonad import RnHsSyn ( RenamedHsDecl, RenamedDeprecation ) import ParseIface ( parseIface, IfaceStuff(..) ) -import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, listToFM, - lookupFM, addToFM, addToFM_C, addListToFM, - fmToList, elemFM, foldFM - ) -import Name ( Name {-instance NamedThing-}, - nameModule, isLocallyDefined, +import Name ( Name {-instance NamedThing-}, nameOccName, + nameModule, isLocallyDefined, isWiredInName, nameUnique, NamedThing(..) ) import Module ( Module, moduleString, pprModule, @@ -57,18 +58,18 @@ import RdrName ( RdrName, rdrNameOcc ) import NameSet import Var ( Id ) import SrcLoc ( mkSrcLoc, SrcLoc ) -import PrelMods ( pREL_GHC ) -import PrelInfo ( cCallishTyKeys ) -import Bag +import PrelInfo ( pREL_GHC, cCallishTyKeys ) import Maybes ( MaybeErr(..), maybeToBool, orElse ) import ListSetOps ( unionLists ) -import Outputable -import Unique ( Unique ) +import Unique ( Unique, Uniquable(..) ) import StringBuffer ( StringBuffer, hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) +import Util ( sortLt, lengthExceeds ) import Lex +import FiniteMap import Outputable +import Bag import IO ( isDoesNotExistError ) import List ( nub ) @@ -120,7 +121,7 @@ tryLoadInterface doc_str mod_name from ImportByUserSource -> True ; -- hi-boot ImportBySystem -> case mod_info of - Just (_, _, is_boot, _) -> is_boot + Just (_, is_boot, _) -> is_boot Nothing -> False -- We're importing a module we know absolutely @@ -130,12 +131,12 @@ tryLoadInterface doc_str mod_name from } redundant_source_import = case (from, mod_info) of - (ImportByUserSource, Just (_,_,False,_)) -> True + (ImportByUserSource, Just (_,False,_)) -> True other -> False in -- CHECK WHETHER WE HAVE IT ALREADY case mod_info of { - Just (_, _, _, Just _) + Just (_, _, Just _) -> -- We're read it already so don't re-read it returnRn (ifaces, Nothing) ; @@ -154,7 +155,7 @@ tryLoadInterface doc_str mod_name from -- so that we don't look again let mod = mkVanillaModule mod_name - new_mod_map = addToFM mod_map mod_name (0, False, False, Just (mod, from, [])) + new_mod_map = addToFM mod_map mod_name (False, False, Just (mod, 0, 0, 0, from, [])) new_ifaces = ifaces { iImpModInfo = new_mod_map } in setIfacesRn new_ifaces `thenRn_` @@ -172,8 +173,7 @@ tryLoadInterface doc_str mod_name from getModuleRn `thenRn` \ this_mod_nm -> let - rd_decls = pi_decls iface - mod = pi_mod iface + mod = pi_mod iface in -- Sanity check. If we're system-importing a module we know nothing at all -- about, it should be from a different package to this one @@ -181,16 +181,12 @@ tryLoadInterface doc_str mod_name from case from of { ImportBySystem -> True; other -> False } && isLocalModule mod, ppr mod ) - foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls -> - foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - (if opt_IgnoreIfacePragmas - then returnRn emptyBag - else foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface)) `thenRn` \ new_rules -> - (if opt_IgnoreIfacePragmas - then returnRn emptyNameEnv - else foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface)) `thenRn` \ new_deprecs -> - foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> - mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s -> + foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls -> + foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> + loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules -> + loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities -> + foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs -> + mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s -> let -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted @@ -201,8 +197,10 @@ tryLoadInterface doc_str mod_name from -- Now add info about this module mod_map2 = addToFM mod_map1 mod_name mod_details - cts = (pi_mod iface, from, concat avails_s) - mod_details = (pi_vers iface, pi_orphan iface, hi_boot_file, Just cts) + cts = (pi_mod iface, pi_vers iface, + fst (pi_fixity iface), fst (pi_rules iface), + from, concat avails_s) + mod_details = (pi_orphan iface, hi_boot_file, Just cts) new_ifaces = ifaces { iImpModInfo = mod_map2, iDecls = new_decls, @@ -215,6 +213,11 @@ tryLoadInterface doc_str mod_name from returnRn (new_ifaces, Nothing) }} +----------------------------------------------------- +-- Adding module dependencies from the +-- import decls in the interface file +----------------------------------------------------- + addModDeps :: Module -> [ImportVersion a] -> ImportedModuleInfo -> ImportedModuleInfo -- (addModDeps M ivs deps) @@ -226,20 +229,25 @@ addModDeps mod new_deps mod_deps -- Except for its descendents which contain orphans, -- and in that case, forget about the boot indicator filtered_new_deps - | isLocalModule mod = [ (imp_mod, (version, has_orphans, is_boot, Nothing)) - | (imp_mod, version, has_orphans, is_boot, _) <- new_deps + | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, Nothing)) + | (imp_mod, has_orphans, is_boot, _) <- new_deps ] - | otherwise = [ (imp_mod, (version, True, False, Nothing)) - | (imp_mod, version, has_orphans, _, _) <- new_deps, + | otherwise = [ (imp_mod, (True, False, Nothing)) + | (imp_mod, has_orphans, _, _) <- new_deps, has_orphans ] add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep - combine old@(_, _, old_is_boot, cts) new + combine old@(_, old_is_boot, cts) new | maybeToBool cts || not old_is_boot = old -- Keep the old info if it's already loaded -- or if it's a non-boot pending load | otherwise = new -- Otherwise pick new info + +----------------------------------------------------- +-- Loading the export list +----------------------------------------------------- + loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo] loadExport this_mod (mod, entities) | mod == this_mod = returnRn [] @@ -273,21 +281,9 @@ loadExport this_mod (mod, entities) returnRn (AvailTC name names) -loadFixDecl :: ModuleName -> FixityEnv - -> (Version, RdrNameHsDecl) - -> RnM d FixityEnv -loadFixDecl mod_name fixity_env (version, FixD sig@(FixitySig rdr_name fixity loc)) - = -- Ignore the version; when the fixity changes the version of - -- its 'host' entity changes, so we don't need a separate version - -- number for fixities - mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - let - new_fixity_env = addToNameEnv fixity_env name (FixitySig name fixity loc) - in - returnRn new_fixity_env - - -- Ignore the other sorts of decl -loadFixDecl mod_name fixity_env other_decl = returnRn fixity_env +----------------------------------------------------- +-- Loading type/class/value decls +----------------------------------------------------- loadDecl :: Module -> DeclsMap @@ -318,10 +314,13 @@ loadDecl mod decls_map (version, decl) returnRn new_decls_map } where - -- newImportedBinder puts into the cache the binder with the + -- newTopBinder puts into the cache the binder with the -- module information set correctly. When the decl is later renamed, -- the binding site will thereby get the correct module. - new_name rdr_name loc = newImportedBinder mod rdr_name + -- There maybe occurrences that don't have the correct Module, but + -- by the typechecker will propagate the binding definition to all + -- the occurrences, so that doesn't matter + new_name rdr_name loc = newTopBinder mod (rdrNameOcc rdr_name) {- If a signature decl is being loaded, and optIgnoreIfacePragmas is on, @@ -344,6 +343,26 @@ loadDecl mod decls_map (version, decl) -> SigD (IfaceSig name tp [] loc) other -> decl +----------------------------------------------------- +-- Loading fixity decls +----------------------------------------------------- + +loadFixDecls mod_name fixity_env (version, decls) + | null decls = returnRn fixity_env + + | otherwise + = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> + returnRn (addListToNameEnv fixity_env to_add) + +loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) + = mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> + returnRn (name, FixitySig name fixity loc) + + +----------------------------------------------------- +-- Loading instance decls +----------------------------------------------------- + loadInstDecl :: Module -> Bag GatedDecl -> RdrNameInstDecl @@ -375,42 +394,66 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty) removeContext ty = removeFuns ty -removeFuns (MonoFunTy _ ty) = removeFuns ty +removeFuns (HsFunTy _ ty) = removeFuns ty removeFuns ty = ty -loadRule :: Module -> Bag GatedDecl - -> RdrNameRuleDecl -> RnM d (Bag GatedDecl) +----------------------------------------------------- +-- Loading Rules +----------------------------------------------------- + +loadRules :: Module -> IfaceRules + -> (Version, [RdrNameRuleDecl]) + -> RnM d IfaceRules +loadRules mod rule_bag (version, rules) + | null rules || opt_IgnoreIfacePragmas + = returnRn rule_bag + | otherwise + = setModuleRn mod_name $ + mapRn (loadRule mod) rules `thenRn` \ new_rules -> + returnRn (rule_bag `unionBags` listToBag new_rules) + where + mod_name = moduleName mod + +loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. -loadRule mod rules decl@(IfaceRuleDecl var body src_loc) - = setModuleRn (moduleName mod) $ - mkImportedGlobalFromRdrName var `thenRn` \ var_name -> - returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules) +loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) + = mkImportedGlobalFromRdrName var `thenRn` \ var_name -> + returnRn (unitNameSet var_name, (mod, RuleD decl)) + +loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG () +loadBuiltinRules builtin_rules + = getIfacesRn `thenRn` \ ifaces -> + mapRn loadBuiltinRule builtin_rules `thenRn` \ rule_decls -> + setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls }) + +loadBuiltinRule (var, rule) + = mkImportedGlobalFromRdrName var `thenRn` \ var_name -> + returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule))) + + +----------------------------------------------------- +-- Loading Deprecations +----------------------------------------------------- --- SUP: TEMPORARY HACK, ignoring module deprecations for now loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv -loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt) +loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt _) = traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_` + -- SUP: TEMPORARY HACK, ignoring module deprecations for now returnRn deprec_env -loadDeprec mod deprec_env (Deprecation ie txt) + +loadDeprec mod deprec_env (Deprecation ie txt _) = setModuleRn (moduleName mod) $ - mapRn mkImportedGlobalFromRdrName (namesFromIE ie) `thenRn` \ names -> + mapRn mkImportedGlobalFromRdrName (ieNames ie) `thenRn` \ names -> traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_` returnRn (extendNameEnv deprec_env (zip names (repeat txt))) - -namesFromIE :: IE a -> [a] -namesFromIE (IEVar n ) = [n] -namesFromIE (IEThingAbs n ) = [n] -namesFromIE (IEThingAll n ) = [n] -namesFromIE (IEThingWith n ns) = n:ns -namesFromIE (IEModuleContents _ ) = [] \end{code} %******************************************************** %* * -\subsection{Loading usage information} +\subsection{Checking usage information} %* * %******************************************************** @@ -418,31 +461,14 @@ namesFromIE (IEModuleContents _ ) = [] upToDate = True outOfDate = False -checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile - -- When this guy is called, we already know that the - -- source code is unchanged from last time -checkUpToDate mod_name - = getIfacesRn `thenRn` \ ifaces -> - findAndReadIface doc_str mod_name - False {- Not hi-boot -} `thenRn` \ read_result -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case read_result of - Left err -> -- Old interface file not found, or garbled, so we'd better bail out - traceRn (vcat [ptext SLIT("No old iface") <+> pprModuleName mod_name, - err]) `thenRn_` - returnRn outOfDate - - Right iface - -> -- Found it, so now check it - checkModUsage (pi_usages iface) - where - -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] +checkModUsage :: [ImportVersion OccName] -> RnMG Bool +-- Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date! -checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) +checkModUsage ((mod_name, _, _, NothingAtAll) : rest) -- If CurrentModule.hi contains -- import Foo :: ; -- then that simply records that Foo lies below CurrentModule in the @@ -451,19 +477,25 @@ checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_` checkModUsage rest -- This one's ok, so check the rest -checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) +checkModUsage ((mod_name, _, _, whats_imported) : rest) = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> case maybe_err of { - Just err -> traceRn (sep [ptext SLIT("Can't find version number for module"), - pprModuleName mod_name]) `thenRn_` - returnRn outOfDate ; + Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), + pprModuleName mod_name]) ; -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted + Nothing -> let - new_mod_vers = case lookupFM (iImpModInfo ifaces) mod_name of - Just (version, _, _, _) -> version + (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _) + = case lookupFM (iImpModInfo ifaces) mod_name of + Just (_, _, Just stuff) -> stuff + + old_mod_vers = case whats_imported of + Everything v -> v + Specifically v _ _ _ -> v + -- NothingAtAll case dealt with by previous eqn for checkModUsage in -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then @@ -477,19 +509,25 @@ checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) -- If the usage info wants to say "I imported everything from this module" -- it does so by making whats_imported equal to Everything -- In that case, we must recompile - case whats_imported of { - Everything -> traceRn (ptext SLIT("...and I needed the whole module")) `thenRn_` - returnRn outOfDate; -- Bale out + case whats_imported of { -- NothingAtAll dealt with earlier + + Everything _ + -> out_of_date (ptext SLIT("...and I needed the whole module")) ; - Specifically old_local_vers -> + Specifically _ old_fix_vers old_rule_vers old_local_vers -> + if old_fix_vers /= new_fix_vers then + out_of_date (ptext SLIT("Fixities changed")) + else if old_rule_vers /= new_rule_vers then + out_of_date (ptext SLIT("Rules changed")) + else -- Non-empty usage list, so check item by item checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> if up_to_date then traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else - returnRn outOfDate -- This one failed, so just bail out now + returnRn outOfDate -- This one failed, so just bail out now }} where doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name] @@ -503,8 +541,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) case lookupNameEnv decls name of Nothing -> -- We used it before, but it ain't there now - traceRn (sep [ptext SLIT("No longer exported:"), ppr name]) - `thenRn_` returnRn outOfDate + out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) Just (new_vers,_,_,_) -- It's there, but is it up to date? | new_vers == old_vers @@ -513,8 +550,9 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) | otherwise -- Out of date, so bale out - -> traceRn (sep [ptext SLIT("Out of date:"), ppr name]) `thenRn_` - returnRn outOfDate + -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) + +out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate \end{code} @@ -525,44 +563,111 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -importDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) - -- Returns Nothing for - -- (a) wired in name - -- (b) local decl - -- (c) already slurped +importDecl :: Name -> RnMG ImportDeclResult + +data ImportDeclResult + = AlreadySlurped + | WiredIn + | Deferred + | HereItIs (Module, RdrNameHsDecl) importDecl name - | isWiredInName name - = returnRn Nothing - | otherwise = getSlurped `thenRn` \ already_slurped -> if name `elemNameSet` already_slurped then - returnRn Nothing -- Already dealt with - else - if isLocallyDefined name then -- Don't bring in decls from + returnRn AlreadySlurped -- Already dealt with + + else if isLocallyDefined name then -- Don't bring in decls from -- the renamed module's own interface file - addWarnRn (importDeclWarn name) `thenRn_` - returnRn Nothing - else - getNonWiredInDecl name -\end{code} + addWarnRn (importDeclWarn name) `thenRn_` + returnRn AlreadySlurped -\begin{code} -getNonWiredInDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) + else if isWiredInName name then + -- When we find a wired-in name we must load its + -- home module so that we find any instance decls therein + loadHomeInterface doc name `thenRn_` + returnRn WiredIn + + else getNonWiredInDecl name + where + doc = ptext SLIT("need home module for wired in thing") <+> ppr name + + +{- I don't think this is necessary any more; SLPJ May 00 + load_home name + | name `elemNameSet` source_binders = returnRn () + -- When compiling the prelude, a wired-in thing may + -- be defined in this module, in which case we don't + -- want to load its home module! + -- Using 'isLocallyDefined' doesn't work because some of + -- the free variables returned are simply 'listTyCon_Name', + -- with a system provenance. We could look them up every time + -- but that seems a waste. + | otherwise = loadHomeInterface doc name `thenRn_` + returnRn () +-} + +getNonWiredInDecl :: Name -> RnMG ImportDeclResult getNonWiredInDecl needed_name = traceRn doc_str `thenRn_` loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> case lookupNameEnv (iDecls ifaces) needed_name of + Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _))) + -- This case deals with deferred import of algebraic data types + + | not opt_NoPruneTyDecls + + && (opt_IgnoreIfacePragmas || ncons > 1) + -- We only defer if imported interface pragmas are ingored + -- or if it's not a product type. + -- Sole reason: The wrapper for a strict function may need to look + -- inside its arg, and hence need to see its arg type's constructors. + + && not (getUnique tycon_name `elem` cCallishTyKeys) + -- Never defer ccall types; we have to unbox them, + -- and importing them does no harm + + -> -- OK, so we're importing a deferrable data type + if needed_name == tycon_name then + -- The needed_name is the TyCon of a data type decl + -- Record that it's slurped, put it in the deferred set + -- and don't return a declaration at all + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + `addOneToNameSet` tycon_name}) + version (AvailTC needed_name [needed_name])) `thenRn_` + returnRn Deferred + else + -- The needed name is a constructor of a data type decl, + -- getting a constructor, so remove the TyCon from the deferred set + -- (if it's there) and return the full declaration + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + `delFromNameSet` tycon_name}) + version avail) `thenRn_` + returnRn (HereItIs decl) + where + tycon_name = availName avail + Just (version,avail,_,decl) - -> recordSlurp (Just version) avail `thenRn_` - returnRn (Just decl) + -> setIfacesRn (recordSlurp ifaces version avail) `thenRn_` + returnRn (HereItIs decl) - Nothing -- Can happen legitimately for "Optional" occurrences + Nothing -> addErrRn (getDeclErr needed_name) `thenRn_` - returnRn Nothing + returnRn AlreadySlurped where doc_str = ptext SLIT("need decl for") <+> ppr needed_name + +getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] +getDeferredDecls + = getIfacesRn `thenRn` \ ifaces -> + let + decls_map = iDecls ifaces + deferred_names = nameSetToList (iDeferred ifaces) + get_abstract_decl n = case lookupNameEnv decls_map n of + Just (_, _, _, decl) -> decl + in + traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_` + returnRn (map get_abstract_decl deferred_names) \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. @@ -600,7 +705,7 @@ getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails) getInterfaceExports mod_name from = loadInterface doc_str mod_name from `thenRn` \ ifaces -> case lookupFM (iImpModInfo ifaces) mod_name of - Just (_, _, _, Just (mod, _, avails)) -> returnRn (mod, avails) + Just (_, _, Just (mod, _, _, _, _, avails)) -> returnRn (mod, avails) -- loadInterface always puts something in the map -- even if it's a fake where @@ -622,7 +727,7 @@ getImportedInstDecls gates getIfacesRn `thenRn` \ ifaces -> let orphan_mods = - [mod | (mod, (_, True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] + [mod | (mod, (True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] in loadOrphanModules orphan_mods `thenRn_` @@ -655,11 +760,15 @@ getImportedRules = getIfacesRn `thenRn` \ ifaces -> let gates = iSlurp ifaces -- Anything at all that's been slurped - (decls, new_rules) = selectGated gates (iRules ifaces) + rules = iRules ifaces + (decls, new_rules) = selectGated gates rules in - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + if null decls then + returnRn [] + else + setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` returnRn decls selectGated gates decl_bag @@ -676,13 +785,11 @@ selectGated gates decl_bag | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) | otherwise = (yes, (reqd,decl) `consBag` no) -lookupFixity :: Name -> RnMS Fixity -lookupFixity name +lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn name | isLocallyDefined name = getFixityEnv `thenRn` \ local_fix_env -> - case lookupNameEnv local_fix_env name of - Just (FixitySig _ fix _) -> returnRn fix - Nothing -> returnRn defaultFixity + returnRn (lookupFixity local_fix_env name) | otherwise -- Imported -- For imported names, we have to get their fixities by doing a loadHomeInterface, @@ -693,9 +800,7 @@ lookupFixity name -- When we come across a use of 'f', we need to know its fixity, and it's then, -- and only then, that we load B.hi. That is what's happening here. = loadHomeInterface doc name `thenRn` \ ifaces -> - case lookupNameEnv (iFixes ifaces) name of - Just (FixitySig _ fix _) -> returnRn fix - Nothing -> returnRn defaultFixity + returnRn (lookupFixity (iFixes ifaces) name) where doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} @@ -759,20 +864,32 @@ imports A. This line says that A imports B, but uses nothing in it. So we'll get an early bale-out when compiling A if B's version changes. \begin{code} -getImportVersions :: ModuleName -- Name of this module - -> ExportEnv -- Info about exports - -> RnMG (VersionInfo Name) -- Version info for these names - -getImportVersions this_mod (ExportEnv _ _ export_all_mods) +mkImportExportInfo :: ModuleName -- Name of this module + -> Avails -- Info about exports + -> Maybe [RdrNameIE] -- The export header + -> RnMG ([ExportItem], -- Export info for iface file; sorted + [ImportVersion OccName]) -- Import info for iface file; sorted + -- Both results are sorted into canonical order to + -- reduce needless wobbling of interface files + +mkImportExportInfo this_mod export_avails exports = getIfacesRn `thenRn` \ ifaces -> let + export_all_mods = case exports of + Nothing -> [] + Just es -> [mod | IEModuleContents mod <- es, + mod /= this_mod] + mod_map = iImpModInfo ifaces imp_names = iVSlurp ifaces -- mv_map groups together all the things imported from a particular module. - mv_map :: FiniteMap ModuleName [(Name,Version)] + mv_map :: FiniteMap ModuleName [(OccName,Version)] mv_map = foldr add_mv emptyFM imp_names + add_mv (name, version) mv_map = addItem mv_map (moduleName (nameModule name)) + (nameOccName name, version) + -- Build the result list by adding info for each module. -- For (a) a library module, we don't record it at all unless it contains orphans -- (We must never lose track of orphans.) @@ -789,7 +906,7 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- whether something is a boot file along with the usage info for it, but -- I can't be bothered just now. - mk_version_info mod_name (version, has_orphans, is_boot, contents) so_far + mk_imp_info mod_name (has_orphans, is_boot, contents) so_far | mod_name == this_mod -- Check if M appears in the set of modules 'below' M -- This seems like a convenient place to check = WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+> @@ -798,7 +915,7 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) | otherwise = let - go_for_it exports = (mod_name, version, has_orphans, is_boot, exports) + go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far in case contents of @@ -809,20 +926,21 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- information. The Nothing says that we didn't even open the interface -- file but we must still propagate the dependeny info. -- The module in question must be a local module (in the same package) - go_for_it (Specifically []) + go_for_it NothingAtAll - Just (mod, how_imported, _) + Just (mod, mod_vers, fix_vers, rule_vers, how_imported, _) | is_sys_import && is_lib_module && not has_orphans -> so_far | is_lib_module -- Record the module but not detailed || mod_name `elem` export_all_mods -- version information for the imports - -> go_for_it Everything + -> go_for_it (Everything mod_vers) | otherwise -> case lookupFM mv_map mod_name of - Just whats_imported -> go_for_it (Specifically whats_imported) - Nothing -> go_for_it (Specifically []) + Just whats_imported -> go_for_it (Specifically mod_vers fix_vers rule_vers + (sortImport whats_imported)) + Nothing -> go_for_it NothingAtAll -- This happens if you have -- import Foo -- but don't actually *use* anything from Foo @@ -833,15 +951,36 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) ImportBySystem -> True other -> False + + import_info = foldFM mk_imp_info [] mod_map + + -- Sort exports into groups by module + export_fm :: FiniteMap ModuleName [RdrAvailInfo] + export_fm = foldr insert emptyFM export_avails + + insert avail efm = addItem efm (moduleName (nameModule (availName avail))) + (rdrAvailInfo avail) + + export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm] in + returnRn (export_info, import_info) - returnRn (foldFM mk_version_info [] mod_map) - where - add_mv v@(name, version) mv_map - = addToFM_C add_item mv_map mod [v] - where - mod = moduleName (nameModule name) - add_item vs _ = (v:vs) + +addItem :: FiniteMap ModuleName [a] -> ModuleName -> a -> FiniteMap ModuleName [a] +addItem fm mod x = addToFM_C add_item fm mod [x] + where + add_item xs _ = x:xs + +sortImport :: [(OccName,Version)] -> [(OccName,Version)] + -- Make the usage lists appear in canonical order +sortImport vs = sortLt lt vs + where + lt (n1,v1) (n2,v2) = n1 < n2 + +sortExport :: [RdrAvailInfo] -> [RdrAvailInfo] +sortExport as = sortLt lt as + where + lt a1 a2 = availName a1 < availName a2 \end{code} \begin{code} @@ -849,20 +988,20 @@ getSlurped = getIfacesRn `thenRn` \ ifaces -> returnRn (iSlurp ifaces) -recordSlurp maybe_version avail --- Nothing for locally defined names --- Just version for imported names - = getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names, - iVSlurp = imp_names }) -> - let +recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names }) + version avail + = let new_slurped_names = addAvailToNameSet slurped_names avail + new_imp_names = (availName avail, version) : imp_names + in + ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names } - new_imp_names = case maybe_version of - Just version -> (availName avail, version) : imp_names - Nothing -> imp_names +recordLocalSlurps local_avails + = getIfacesRn `thenRn` \ ifaces -> + let + new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails in - setIfacesRn (ifaces { iSlurp = new_slurped_names, - iVSlurp = new_imp_names }) + setIfacesRn (ifaces { iSlurp = new_slurped_names }) \end{code} @@ -884,7 +1023,7 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function -> RdrNameHsDecl -> RnM d (Maybe AvailInfo) -getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ src_loc)) +getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> getConFieldNames new_name condecls `thenRn` \ sub_names -> returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names))) @@ -911,7 +1050,8 @@ getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) = new_name var src_loc `thenRn` \ var_name -> returnRn (Just (Avail var_name)) -getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (DeprecD _) = returnRn Nothing -- foreign declarations getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) @@ -967,7 +1107,7 @@ bindings of their own elsewhere. getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc)) = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)] -getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _)) +getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _)) = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] getDeclSysBinders new_name other_decl diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5a7ea505a6..950fe4849a 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -6,10 +6,13 @@ \begin{code} module RnMonad( module RnMonad, + + module RdrName, -- Re-exports + module Name, -- from these two + Module, FiniteMap, Bag, - Name, RdrNameHsDecl, RdrNameInstDecl, Version, @@ -32,33 +35,37 @@ import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig, RenamedDeprecation ) -import BasicTypes ( Version ) +import BasicTypes ( Version, defaultFixity ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message ) -import Name ( Name, OccName, NamedThing(..), +import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc, + RdrNameEnv, emptyRdrEnv, extendRdrEnv, + lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts + ) +import Name ( Name, OccName, NamedThing(..), getSrcLoc, isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName, mkUnboundName + decode, mkLocalName, mkUnboundName, + NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnv, + addToNameEnv_C, plusNameEnv_C, nameEnvElts, + elemNameEnv, addToNameEnv, addListToNameEnv ) import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, - mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath + mkModuleHiMaps, moduleName, mkSearchPath ) import NameSet -import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique, getUnique, unboundKey ) -import UniqFM ( UniqFM ) import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, addListToFM_C, addToFM_C, eltsFM, fmToList ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import Maybes ( mapMaybe ) import UniqSet -import UniqFM import UniqSupply import Util import Outputable @@ -148,57 +155,23 @@ data RnMode = SourceMode -- Renaming source code \begin{code} -------------------------------- -type RdrNameEnv a = FiniteMap RdrName a type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes -- These only get reported on lookup, -- not on construction type LocalRdrEnv = RdrNameEnv Name -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList - --------------------------------- -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -nameEnvElts :: NameEnv a -> [a] -addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a - -emptyNameEnv = emptyUFM -nameEnvElts = eltsUFM -addToNameEnv_C = addToUFM_C -addToNameEnv = addToUFM -plusNameEnv = plusUFM -plusNameEnv_C = plusUFM_C -extendNameEnv = addListToUFM -lookupNameEnv = lookupUFM -delFromNameEnv = delFromUFM -elemNameEnv = elemUFM -unitNameEnv = unitUFM - -------------------------------- type FixityEnv = NameEnv RenamedFixitySig -- We keep the whole fixity sig so that we -- can report line-number info when there is a duplicate -- fixity declaration +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env name + = case lookupNameEnv env name of + Just (FixitySig _ fix _) -> fix + Nothing -> defaultFixity + -------------------------------- type DeprecationEnv = NameEnv DeprecTxt \end{code} @@ -229,12 +202,7 @@ type RnNameSupply -------------------------------- -data ExportEnv = ExportEnv Avails Fixities [ModuleName] - -- The list of modules is the modules exported - -- with 'module M' in the export list - type Avails = [AvailInfo] -type Fixities = [(Name, Fixity)] type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers @@ -250,6 +218,8 @@ data GenAvailInfo name = Avail name -- An ordinary identifier -- NB: If the type or class is itself -- to be in scope, it must be in this list. -- Thus, typically: AvailTC Eq [Eq, ==, /=] + deriving( Eq ) + -- Equality used when deciding if the interface has changed type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it type AvailInfo = GenAvailInfo Name @@ -262,10 +232,12 @@ type RdrAvailInfo = GenAvailInfo OccName \begin{code} type ExportItem = (ModuleName, [RdrAvailInfo]) -type VersionInfo name = [ImportVersion name] -type ImportVersion name = (ModuleName, Version, - WhetherHasOrphans, IsBootInterface, WhatsImported name) +type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name) + +type ModVersionInfo = (Version, -- Version of the whole module + Version, -- Version number for all fixity decls together + Version) -- ...ditto all rules together type WhetherHasOrphans = Bool -- An "orphan" is @@ -276,15 +248,25 @@ type WhetherHasOrphans = Bool type IsBootInterface = Bool -data WhatsImported name = Everything - | Specifically [LocalVersion name] -- List guaranteed non-empty +data WhatsImported name = NothingAtAll -- The module is below us in the + -- hierarchy, but we import nothing - -- ("M", hif, ver, Everything) means there was a "module M" in - -- this module's export list, so we just have to go by M's version, "ver", - -- not the list of LocalVersions. + | Everything Version -- The module version + | Specifically Version -- Module version + Version -- Fixity version + Version -- Rules version + [(name,Version)] -- List guaranteed non-empty + deriving( Eq ) + -- 'Specifically' doesn't let you say "I imported f but none of the fixities in + -- the module. If you use anything in the module you get its fixity and rule version + -- So if the fixities or rules change, you'll recompile, even if you don't use either. + -- This is easy to implement, and it's safer: you might not have used the rules last + -- time round, but if someone has added a new rule you might need it this time -type LocalVersion name = (name, Version) + -- 'Everything' means there was a "module M" in + -- this module's export list, so we just have to go by M's version, + -- not the list of (name,version) pairs data ParsedIface = ParsedIface { @@ -293,23 +275,13 @@ data ParsedIface pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages pi_exports :: [ExportItem], -- Exports - pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: [RdrNameRuleDecl], -- Rules + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, with their version + pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version pi_deprecs :: [RdrNameDeprecation] -- Deprecations } -data InterfaceDetails - = InterfaceDetails WhetherHasOrphans - (VersionInfo Name) -- Version information for what this module imports - ExportEnv -- What modules this one depends on - [Deprecation Name] - - --- needed by Main to fish out the fixities assoc list. -getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (InterfaceDetails _ _ (ExportEnv _ fs _) _) = fs - type RdrNamePragma = () -- Fudge for now ------------------- @@ -323,8 +295,14 @@ data Ifaces = Ifaces { iDecls :: DeclsMap, -- A single, global map of Names to decls - iFixes :: FixityEnv, -- A single, global map of Names to fixities - -- See comments with RnIfaces.lookupFixity + iDeferred :: NameSet, -- data (not newtype) TyCons that have been slurped, + -- but none of their constructors have. + -- If this is still the case right at the end + -- we can get away with importing them abstractly + + iFixes :: FixityEnv, + -- A single, global map of Names to fixities + -- See comments with RnIfaces.lookupFixity iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, @@ -342,17 +320,24 @@ data Ifaces = Ifaces { -- Each is 'gated' by the names that must be available before -- this instance decl is needed. - iRules :: Bag GatedDecl, - -- Ditto transformation rules + iRules :: IfaceRules, + -- Similar to instance decls, except that we track the version number of the + -- rules we import from each module + -- [We keep just one rule-version number for each module] + -- The Bool is True if we import any rules at all from that module iDeprecs :: DeprecationEnv } +type IfaceRules = Bag GatedDecl + type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) type ImportedModuleInfo - = FiniteMap ModuleName (Version, WhetherHasOrphans, IsBootInterface, - Maybe (Module, WhereFrom, Avails)) + = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface, + Maybe (Module, Version, Version, Version, WhereFrom, Avails)) + -- The three Versions are module version, fixity version, rules version + -- Suppose the domain element is module 'A' -- -- The first Bool is True if A contains @@ -427,6 +412,7 @@ initIfaceRnMS mod thing_inside emptyIfaces :: Ifaces emptyIfaces = Ifaces { iImpModInfo = emptyFM, iDecls = emptyNameEnv, + iDeferred = emptyNameSet, iFixes = emptyNameEnv, iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), -- Pretend that the dummy unbound name has already been diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index ba7cbc62bc..979bc00861 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -24,14 +24,13 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, getDeclBinders, getDeclSysBinders, - recordSlurp, checkUpToDate + recordLocalSlurps, checkModUsage, findAndReadIface, outOfDate ) import RnEnv import RnMonad import FiniteMap -import PrelMods -import PrelInfo ( main_RDR ) +import PrelInfo ( pRELUDE_Name, mAIN_Name, main_RDR ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) @@ -40,7 +39,7 @@ import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), isLocallyDefined, setNameProvenance, nameOccName, getSrcLoc, pprProvenance, getNameProvenance ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual ) import OccName ( setOccNameSpace, dataName ) import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) @@ -62,25 +61,26 @@ import List ( partition ) \begin{code} getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (ExportEnv, - GlobalRdrEnv, - FixityEnv, -- Fixities for local decls only - AvailEnv -- Maps a name to its parent AvailInfo - -- Just for in-scope things only + -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things + GlobalRdrEnv, -- Maps just *local* things + Avails, -- The exported stuff + AvailEnv, -- Maps a name to its parent AvailInfo + -- Just for in-scope things only + Maybe ParsedIface -- The old interface file, if any )) -- Nothing => no need to recompile getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name - fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) -> + fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _, _)) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? rec_unqual_fn = unQualInScope rec_gbl_env rec_exp_fn :: Name -> ExportFlag - rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails) + rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails) in setModuleRn this_mod $ @@ -113,74 +113,54 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) all_avails :: ExportAvails all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) + (_, global_avail_env) = all_avails in - -- TRY FOR EARLY EXIT - -- We can't go for an early exit before this because we have to check - -- for name clashes. Consider: - -- - -- module A where module B where - -- import B h = True - -- f = h - -- - -- Suppose I've compiled everything up, and then I add a - -- new definition to module B, that defines "f". - -- - -- Then I must detect the name clash in A before going for an early - -- exit. The early-exit code checks what's actually needed from B - -- to compile A, and of course that doesn't include B.f. That's - -- why we wait till after the plusEnv stuff to do the early-exit. - checkEarlyExit this_mod `thenRn` \ up_to_date -> - if up_to_date then - returnRn (gbl_env, junk_exp_fn, Nothing) - else - - -- RECORD BETTER PROVENANCES IN THE CACHE - -- The names in the envirnoment have better provenances (e.g. imported on line x) - -- than the names in the name cache. We update the latter now, so that we - -- we start renaming declarations we'll get the good names - -- The isQual is because the qualified name is always in scope - updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env, - isQual rdr_name]) `thenRn_` - - -- PROCESS EXPORT LISTS - exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails -> - - -- DONE - returnRn (gbl_env, exported_avails, Just all_avails) - ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) -> - - case maybe_stuff of { - Nothing -> returnRn Nothing ; - Just all_avails -> - - -- DEAL WITH FIXITIES - fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> - let - -- Export only those fixities that are for names that are - -- (a) defined in this module - -- (b) exported - exported_fixities :: [(Name,Fixity)] - exported_fixities = [(name,fixity) - | FixitySig name fixity _ <- nameEnvElts local_fixity_env, - isLocallyDefined name - ] - - -- CONSTRUCT RESULTS - export_mods = case exports of - Nothing -> [] - Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod] - - export_env = ExportEnv exported_avails exported_fixities export_mods - (_, global_avail_env) = all_avails - in - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_` - - returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env)) - } + -- TRY FOR EARLY EXIT + -- We can't go for an early exit before this because we have to check + -- for name clashes. Consider: + -- + -- module A where module B where + -- import B h = True + -- f = h + -- + -- Suppose I've compiled everything up, and then I add a + -- new definition to module B, that defines "f". + -- + -- Then I must detect the name clash in A before going for an early + -- exit. The early-exit code checks what's actually needed from B + -- to compile A, and of course that doesn't include B.f. That's + -- why we wait till after the plusEnv stuff to do the early-exit. + + -- Check For eacly exit + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + returnRn Nothing + else + checkEarlyExit this_mod `thenRn` \ (up_to_date, old_iface) -> + if up_to_date then + -- Interface files are sufficiently unchanged + putDocRn (text "Compilation IS NOT required") `thenRn_` + returnRn Nothing + else + + -- RECORD BETTER PROVENANCES IN THE CACHE + -- The names in the envirnoment have better provenances (e.g. imported on line x) + -- than the names in the name cache. We update the latter now, so that we + -- we start renaming declarations we'll get the good names + -- The isQual is because the qualified name is always in scope + updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList gbl_env, + isQual rdr_name]) `thenRn_` + + -- PROCESS EXPORT LISTS + exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails -> + + + -- ALL DONE + returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface)) + ) where - junk_exp_fn = error "RnNames:export_fn" - all_imports = prel_imports ++ imports -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); @@ -203,27 +183,32 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) \end{code} \begin{code} -checkEarlyExit mod - = checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - returnRn True - else - - traceRn (text "Considering whether compilation is required...") `thenRn_` - if not opt_SourceUnchanged then - -- Source code changed and no errors yet... carry on - traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` - returnRn False - else - - -- Unchanged source, and no errors yet; see if usage info - -- up to date, and exit if so - checkUpToDate mod `thenRn` \ up_to_date -> - (if up_to_date - then putDocRn (text "Compilation IS NOT required") - else returnRn ()) `thenRn_` - returnRn up_to_date +checkEarlyExit mod_name + = traceRn (text "Considering whether compilation is required...") `thenRn_` + + -- Read the old interface file, if any, for the module being compiled + findAndReadIface doc_str mod_name False {- Not hi-boot -} `thenRn` \ maybe_iface -> + + -- CHECK WHETHER WE HAVE IT ALREADY + case maybe_iface of + Left err -> -- Old interface file not found, so we'd better bail out + traceRn (vcat [ptext SLIT("No old interface file for") <+> pprModuleName mod_name, + err]) `thenRn_` + returnRn (outOfDate, Nothing) + + Right iface + | not opt_SourceUnchanged + -> -- Source code changed + traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` + returnRn (False, Just iface) + + | otherwise + -> -- Source code unchanged and no errors yet... carry on + checkModUsage (pi_usages iface) `thenRn` \ up_to_date -> + returnRn (up_to_date, Just iface) + where + -- Only look in current directory, with suffix .hi + doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] \end{code} \begin{code} @@ -285,7 +270,7 @@ importsFromLocalDecls mod_name rec_exp_fn decls mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` -- Record that locally-defined things are available - mapRn_ (recordSlurp Nothing) avails `thenRn_` + recordLocalSlurps avails `thenRn_` -- Build the environment qualifyImports mod_name @@ -298,15 +283,16 @@ importsFromLocalDecls mod_name rec_exp_fn decls mod = mkThisModule mod_name newLocalName rdr_name loc - = (if isQual rdr_name then - qualNameErr (text "the binding for" <+> quotes (ppr rdr_name)) (rdr_name,loc) - -- There should never be a qualified name in a binding position (except in instance decls) - -- The parser doesn't check this because the same parser parses instance decls - else - returnRn ()) `thenRn_` - - newLocalTopBinder mod (rdrNameOcc rdr_name) rec_exp_fn loc + = check_unqual rdr_name loc `thenRn_` + newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name -> + returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name))) + -- There should never be a qualified name in a binding position (except in instance decls) + -- The parser doesn't check this because the same parser parses instance decls + check_unqual rdr_name loc + | isUnqual rdr_name = returnRn () + | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name)) + (rdr_name,loc) getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function -> RdrNameHsDecl @@ -327,38 +313,6 @@ getLocalDeclBinders new_name decl -- The getDeclSysBinders is just to get the names of superclass selectors -- etc, into the cache new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc - -fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv -fixitiesFromLocalDecls gbl_env decls - = foldlRn getFixities emptyNameEnv decls - where - getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv - getFixities acc (FixD fix) - = fix_decl acc fix - - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) - = foldlRn fix_decl acc [sig | FixSig sig <- sigs] - -- Get fixities from class decl sigs too. - getFixities acc other_decl - = returnRn acc - - fix_decl acc sig@(FixitySig rdr_name fixity loc) - = -- Check for fixity decl for something not declared - case lookupRdrEnv gbl_env rdr_name of { - Nothing | opt_WarnUnusedBinds - -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) - `thenRn_` returnRn acc - | otherwise -> returnRn acc ; - - Just (name:_) -> - - -- Check for duplicate fixity decl - case lookupNameEnv acc name of { - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') - `thenRn_` returnRn acc ; - - Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) - }} \end{code} %************************************************************************ @@ -750,12 +704,4 @@ dupModuleExport mod = hsep [ptext SLIT("Duplicate"), quotes (ptext SLIT("Module") <+> pprModuleName mod), ptext SLIT("in export list")] - -unusedFixityDecl rdr_name fixity - = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] - -dupFixityDecl rdr_name loc1 loc2 - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("at ") <+> ppr loc1, - ptext SLIT("and") <+> ppr loc2] \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 40be2b7287..ccd609623d 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,15 +4,15 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where +module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where #include "HsVersions.h" import RnExpr import HsSyn import HsPragmas -import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar ) +import HsTypes ( getTyVarName ) +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars ) @@ -21,7 +21,7 @@ import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName, - lookupImplicitOccRn, + lookupImplicitOccRn, lookupImplicitOccsRn, bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, bindCoreLocalFVRn, bindCoreLocalsFVRn, @@ -33,6 +33,7 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName, import RnMonad import FunDeps ( oclose ) +import Class ( FunDep ) import Name ( Name, OccName, ExportFlag(..), Provenance(..), @@ -42,8 +43,8 @@ import NameSet import OccName ( mkDefaultMethodOcc ) import BasicTypes ( TopLevelFlag(..) ) import FiniteMap ( elemFM ) -import PrelInfo ( derivableClassKeys, - deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME, returnIO_NAME +import PrelInfo ( derivableClassKeys, cCallishClassKeys, + deRefStablePtr_RDR, makeStablePtr_RDR, bindIO_RDR ) import Bag ( bagToList ) import List ( partition, nub ) @@ -87,11 +88,12 @@ rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars) rnSourceDecls decls = go emptyFVs [] decls where - -- Fixity decls have been dealt with already; ignore them - go fvs ds' [] = returnRn (ds', fvs) - go fvs ds' (FixD _:ds) = go fvs ds' ds - go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> - go (fvs `plusFV` fvs') (d':ds') ds + -- Fixity and deprecations have been dealt with already; ignore them + go fvs ds' [] = returnRn (ds', fvs) + go fvs ds' (FixD _:ds) = go fvs ds' ds + go fvs ds' (DeprecD _:ds) = go fvs ds' ds + go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> + go (fvs `plusFV` fvs') (d':ds') ds \end{code} @@ -111,9 +113,9 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ - lookupBndrRn name `thenRn` \ name' -> - rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) -> - mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> + mkImportedGlobalFromRdrName name `thenRn` \ name' -> + rnHsType doc_str ty `thenRn` \ (ty',fvs1) -> + mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2) where doc_str = text "the interface signature for" <+> quotes (ppr name) @@ -139,7 +141,7 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) +rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn tycon `thenRn` \ tycon' -> bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> @@ -148,7 +150,7 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragma mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' + returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs derivings' noDataPragmas src_loc), cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs) where @@ -159,7 +161,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn name `thenRn` \ name' -> bindTyVarsFVRn syn_doc tyvars $ \ tyvars' -> - rnHsPolyType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) -> + rnHsType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) -> returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) @@ -349,26 +351,23 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) = pushSrcLocRn src_loc $ lookupOccRn name `thenRn` \ name' -> let - ok_ext_nm Dynamic = True - ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb - ok_ext_nm (ExtName nm Nothing) = isCLabelString nm - - fvs1 = case imp_exp of - FoImport _ | not isDyn -> emptyFVs - FoLabel -> emptyFVs - FoExport | isDyn -> mkNameSet [makeStablePtr_NAME, - deRefStablePtr_NAME, - bindIO_NAME, returnIO_NAME] - | otherwise -> mkNameSet [name'] - _ -> emptyFVs + extra_fvs FoExport + | isDyn = lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR] + | otherwise = returnRn (unitFV name') + extra_fvs other = returnRn emptyFVs in checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` + extra_fvs imp_exp `thenRn` \ fvs1 -> rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs1 `plusFV` fvs2) where fo_decl_msg = ptext SLIT("a foreign declaration") isDyn = isDynamicExtName ext_nm + + ok_ext_nm Dynamic = True + ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb + ok_ext_nm (ExtName nm Nothing) = isCLabelString nm \end{code} %********************************************************* @@ -378,13 +377,23 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) %********************************************************* \begin{code} -rnDecl (RuleD (IfaceRuleDecl var body src_loc)) - = pushSrcLocRn src_loc $ - lookupOccRn var `thenRn` \ var' -> - rnRuleBody body `thenRn` \ (body', fvs) -> - returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var') +rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc)) + = pushSrcLocRn src_loc $ + lookupOccRn fn `thenRn` \ fn' -> + rnCoreBndrs vars $ \ vars' -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> + rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> + returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc), + (fvs1 `plusFV` fvs2) `addOneFV` fn') -rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) +rnDecl (RuleD (IfaceRuleOut fn rule)) + -- This one is used for BuiltInRules + -- The rule itself is already done, but the thing + -- to attach it to is not. + = lookupOccRn fn `thenRn` \ fn' -> + returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn') + +rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc)) = ASSERT( null tvs ) pushSrcLocRn src_loc $ @@ -400,7 +409,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] in mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` - returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc), + returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc), fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "the transformation rule" <+> ptext rule_name @@ -410,7 +419,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) get_var (RuleBndrSig v _) = v rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) -> + rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) -> returnRn (RuleBndrSig id t', fvs) \end{code} @@ -468,7 +477,7 @@ rnConDetails doc locn (InfixCon ty1 ty2) returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) rnConDetails doc locn (NewCon ty mb_field) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> rn_field mb_field `thenRn` \ new_mb_field -> returnRn (NewCon new_ty new_mb_field, fvs) where @@ -490,15 +499,15 @@ rnField doc (names, ty) returnRn ((new_names, new_ty), fvs) rnBangTy doc (Banged ty) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Banged new_ty, fvs) rnBangTy doc (Unbanged ty) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Unbanged new_ty, fvs) rnBangTy doc (Unpacked ty) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Unpacked new_ty, fvs) -- This data decl will parse OK @@ -528,15 +537,12 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty - = rnHsPolyType (text "the type signature for" <+> doc_str) ty + = rnHsType (text "the type signature for" <+> doc_str) ty --------------------------------------- -rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) --- rnHsPolyType is prepared to see a for-all; rnHsType is not --- The former is called for the top level of type sigs and function args. +rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) ---------------------------------------- -rnHsPolyType doc (HsForAllTy Nothing ctxt ty) +rnHsType doc (HsForAllTy Nothing ctxt ty) -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} @@ -548,7 +554,7 @@ rnHsPolyType doc (HsForAllTy Nothing ctxt ty) checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' -> rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty -rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) +rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- Explicit quantification. -- Check that the forall'd tyvars are a subset of the -- free tyvars in the tau-type part @@ -576,9 +582,79 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' -> rnForAll doc forall_tyvars ctxt' tau -rnHsPolyType doc other_ty = rnHsType doc other_ty +rnHsType doc (HsTyVar tyvar) + = lookupOccRn tyvar `thenRn` \ tyvar' -> + returnRn (HsTyVar tyvar', unitFV tyvar') + +rnHsType doc (HsFunTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + -- Might find a for-all as the arg of a function type + rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2) +rnHsType doc (HsListTy ty) + = rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name) +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys) + -- Don't do lookupOccRn, because this is built-in syntax + -- so it doesn't need to be in scope + = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) -> + returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n') + where + n' = tupleTyCon_name boxity (length tys) + + +rnHsType doc (HsAppTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) + +rnHsType doc (HsPredTy pred) + = rnPred doc pred `thenRn` \ (pred', fvs) -> + returnRn (HsPredTy pred', fvs) + +rnHsType doc (HsUsgForAllTy uv_rdr ty) + = bindUVarRn doc uv_rdr $ \ uv_name -> + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (HsUsgForAllTy uv_name ty', + fvs ) + +rnHsType doc (HsUsgTy usg ty) + = newUsg usg `thenRn` \ (usg', usg_fvs) -> + rnHsType doc ty `thenRn` \ (ty', ty_fvs) -> + -- A for-all can occur inside a usage annotation + returnRn (HsUsgTy usg' ty', + usg_fvs `plusFV` ty_fvs) + where + newUsg usg = case usg of + HsUsOnce -> returnRn (HsUsOnce, emptyFVs) + HsUsMany -> returnRn (HsUsMany, emptyFVs) + HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> + returnRn (HsUsVar uv_name, emptyFVs) + +rnHsTypes doc tys = mapFvRn (rnHsType doc) tys +\end{code} + +\begin{code} +-- We use lookupOcc here because this is interface file only stuff +-- and we need the workers... +rnHsTupCon (HsTupCon n boxity) + = lookupOccRn n `thenRn` \ n' -> + returnRn (HsTupCon n' boxity, unitFV n') + +rnHsTupConWkr (HsTupCon n boxity) + -- Tuple construtors are for the *worker* of the tuple + -- Going direct saves needless messing about + = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' -> + returnRn (HsTupCon n' boxity, unitFV n') +\end{code} + +\begin{code} -- Check that each constraint mentions at least one of the forall'd type variables -- Since the forall'd type variables are a subset of the free tyvars -- of the tau-type part, this guarantees that every constraint mentions @@ -605,94 +681,40 @@ rnForAll doc forall_tyvars ctxt ty rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) -> returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty, cxt_fvs `plusFV` ty_fvs) - ---------------------------------------- -rnHsType doc ty@(HsForAllTy _ _ inner_ty) - = addWarnRn (unexpectedForAllTy ty) `thenRn_` - rnHsPolyType doc ty - -rnHsType doc (MonoTyVar tyvar) - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (MonoTyVar tyvar', unitFV tyvar') - -rnHsType doc (MonoFunTy ty1 ty2) - = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) -> - -- Might find a for-all as the arg of a function type - rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) -> - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a - returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2) - -rnHsType doc (MonoListTy ty) - = rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name) - --- Unboxed tuples are allowed to have poly-typed arguments. These --- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (MonoTupleTy tys boxed) - = (if boxed - then mapFvRn (rnHsType doc) tys - else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) -> - returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name) - where - tup_con_name = tupleTyCon_name boxed (length tys) - -rnHsType doc (MonoTyApp ty1 ty2) - = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> - rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> - returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2) - -rnHsType doc (MonoIParamTy n ty) - = getIPName n `thenRn` \ name -> - rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoIParamTy name ty', fvs) - -rnHsType doc (MonoDictTy clas tys) - = lookupOccRn clas `thenRn` \ clas' -> - rnHsTypes doc tys `thenRn` \ (tys', fvs) -> - returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas') - -rnHsType doc (MonoUsgForAllTy uv_rdr ty) - = bindUVarRn doc uv_rdr $ \ uv_name -> - rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoUsgForAllTy uv_name ty', - fvs ) - -rnHsType doc (MonoUsgTy usg ty) - = newUsg usg `thenRn` \ (usg', usg_fvs) -> - rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) -> - -- A for-all can occur inside a usage annotation - returnRn (MonoUsgTy usg' ty', - usg_fvs `plusFV` ty_fvs) - where - newUsg usg = case usg of - MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs) - MonoUsMany -> returnRn (MonoUsMany, emptyFVs) - MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> - returnRn (MonoUsVar uv_name, emptyFVs) - -rnHsTypes doc tys = mapFvRn (rnHsType doc) tys \end{code} - \begin{code} rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars) - rnContext doc ctxt - = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) -> + = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) -> let - (_, dup_asserts) = removeDups (cmpHsPred compare) theta + (_, dups) = removeDupsEq theta + -- We only have equality, not ordering in -- Check for duplicate assertions -- If this isn't an error, then it ought to be: - mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` - + mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_` returnRn (theta, plusFVs fvs_s) + where + --Someone discovered that @CCallable@ and @CReturnable@ + -- could be used in contexts such as: + -- foo :: CCallable a => a -> PrimIO Int + -- Doing this utterly wrecks the whole point of introducing these + -- classes so we specifically check that this isn't being done. + rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)-> + checkRn (not (bad_pred pred')) + (naughtyCCallContextErr pred') `thenRn_` + returnRn (pred', fvs) + + bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys + bad_pred other = False + rnPred doc (HsPClass clas tys) = lookupOccRn clas `thenRn` \ clas_name -> rnHsTypes doc tys `thenRn` \ (tys', fvs) -> returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name) + rnPred doc (HsPIParam n ty) = getIPName n `thenRn` \ name -> rnHsType doc ty `thenRn` \ (ty', fvs) -> @@ -700,7 +722,7 @@ rnPred doc (HsPIParam n ty) \end{code} \begin{code} -rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars) +rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars) rnFds doc fds = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) -> @@ -736,22 +758,14 @@ rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs) rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs) -rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body - `thenRn` \ (rule_body', fvs) -> - returnRn (HsSpecialise rule_body', fvs) -rnRuleBody (UfRuleBody str vars args rhs) - = rnCoreBndrs vars $ \ vars' -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> - rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> - returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2) \end{code} @UfCore@ expressions. \begin{code} rnCoreExpr (UfType ty) - = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> + = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> returnRn (UfType ty', fvs) rnCoreExpr (UfVar v) @@ -766,13 +780,13 @@ rnCoreExpr (UfLitLit l ty) returnRn (UfLitLit l ty', fvs) rnCoreExpr (UfCCall cc ty) - = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) -> + = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) -> returnRn (UfCCall cc ty', fvs) rnCoreExpr (UfTuple con args) - = lookupOccRn con `thenRn` \ con' -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) -> - returnRn (UfTuple con' args', fvs `addOneFV` con') + = rnHsTupConWkr con `thenRn` \ (con', fvs1) -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) -> + returnRn (UfTuple con' args', fvs1 `plusFV` fvs2) rnCoreExpr (UfApp fun arg) = rnCoreExpr fun `thenRn` \ (fun', fv1) -> @@ -816,7 +830,7 @@ rnCoreExpr (UfLet (UfRec pairs) body) \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) -> + = rnHsType doc ty `thenRn` \ (ty', fvs1) -> bindCoreLocalFVRn name ( \ name' -> thing_inside (UfValBinder name' ty') ) `thenRn` \ (result, fvs2) -> @@ -836,7 +850,7 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> \begin{code} rnCoreAlt (con, bndrs, rhs) - = rnUfCon con `thenRn` \ (con', fvs1) -> + = rnUfCon con bndrs `thenRn` \ (con', fvs1) -> bindCoreLocalsFVRn bndrs ( \ bndrs' -> rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> returnRn ((con', bndrs', rhs'), fvs2) @@ -844,7 +858,7 @@ rnCoreAlt (con, bndrs, rhs) returnRn (result, fvs1 `plusFV` fvs3) rnNote (UfCoerce ty) - = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> + = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> returnRn (UfCoerce ty', fvs) rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs) @@ -852,18 +866,23 @@ rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs) rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs) -rnUfCon UfDefault +rnUfCon UfDefault _ = returnRn (UfDefault, emptyFVs) -rnUfCon (UfDataAlt con) +rnUfCon (UfTupleAlt tup_con) bndrs + = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) -> + returnRn (UfDataAlt con', fvs) + -- Makes the type checker a little easier + +rnUfCon (UfDataAlt con) _ = lookupOccRn con `thenRn` \ con' -> returnRn (UfDataAlt con', unitFV con') -rnUfCon (UfLitAlt lit) +rnUfCon (UfLitAlt lit) _ = returnRn (UfLitAlt lit, emptyFVs) -rnUfCon (UfLitLitAlt lit ty) - = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) -> +rnUfCon (UfLitLitAlt lit ty) _ + = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> returnRn (UfLitLitAlt lit ty', fvs) \end{code} @@ -903,12 +922,6 @@ classTyVarNotInOpTyErr clas_tyvar sig ptext SLIT("does not appear in method signature")]) 4 (ppr sig) -dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (pprHsPred assertion), - ptext SLIT("in the context:")], - nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] - badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] @@ -940,7 +953,7 @@ forAllErr doc ty tyvar univErr doc constraint ty = sep [ptext SLIT("All of the type variable(s) in the constraint") - <+> quotes (pprHsPred constraint) + <+> quotes (ppr constraint) <+> ptext SLIT("are already in scope"), nest 4 (ptext SLIT("At least one must be universally quantified here")) ] @@ -948,15 +961,12 @@ univErr doc constraint ty (ptext SLIT("In") <+> doc) ambigErr doc constraint ty - = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint), + = sep [ptext SLIT("Ambiguous constraint") <+> quotes (ppr constraint), nest 4 (ptext SLIT("in the type:") <+> ppr ty), nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))] $$ (ptext SLIT("In") <+> doc) -unexpectedForAllTy ty - = ptext SLIT("Unexpected forall type:") <+> ppr ty - badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] @@ -971,4 +981,14 @@ badRuleVar name var badExtName :: ExtName -> Message badExtName ext_nm = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")] + +dupClassAssertWarn ctxt (assertion : dups) + = sep [hsep [ptext SLIT("Duplicate class assertion"), + quotes (ppr assertion), + ptext SLIT("in the context:")], + nest 4 (ppr ctxt <+> ptext SLIT("..."))] + +naughtyCCallContextErr (HsPClass clas _) + = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), + ptext SLIT("in a context")] \end{code} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 2aefb2b0e7..ef5ce99979 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,9 +12,7 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, - markBinderInsideLambda, tagBinders, - UsageDetails + occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule ) where #include "HsVersions.h" @@ -42,7 +40,7 @@ import Maybes ( maybeToBool ) import Digraph ( stronglyConnCompR, SCC(..) ) import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import UniqFM ( keysUFM ) -import Util ( zipWithEqual, mapAndUnzip, count ) +import Util ( zipWithEqual, mapAndUnzip ) import Outputable \end{code} @@ -71,6 +69,15 @@ occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned snd (occurAnalyseExpr (\_ -> False) expr) + +occurAnalyseRule :: CoreRule -> CoreRule +occurAnalyseRule rule@(BuiltinRule _) = rule +occurAnalyseRule (Rule str tpl_vars tpl_args rhs) + -- Add occ info to tpl_vars, rhs + = Rule str tpl_vars' tpl_args rhs' + where + (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs + (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -853,15 +860,5 @@ setBinderOcc usage bndr Nothing -> IAmDead Just info -> binderInfoToOccInfo info -markBinderInsideLambda :: CoreBndr -> CoreBndr -markBinderInsideLambda bndr - | isTyVar bndr - = bndr - - | otherwise - = case idOccInfo bndr of - OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once - other -> bndr - funOccZero = funOccurrence 0 \end{code} diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 82ab025131..22472899d0 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -44,21 +44,19 @@ import CoreSyn import CoreUtils ( exprType, exprIsTrivial, exprIsBottom ) import CoreFVs -- all of it +import Subst import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo ) import Var ( Var, TyVar, setVarUnique ) -import VarEnv -import Subst import VarSet +import VarEnv import Name ( getOccName ) import OccName ( occNameUserString ) import Type ( isUnLiftedType, mkPiType, Type ) import BasicTypes ( TopLevelFlag(..) ) import Demand ( isStrict, wwLazy ) -import VarSet -import VarEnv import UniqSupply import Util ( sortLt, isSingleton, count ) import Outputable @@ -674,7 +672,8 @@ cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, cloneVar TopLevel env v ctxt_lvl dest_lvl = returnUs (env, v) -- Don't clone top level things cloneVar NotTopLevel env v ctxt_lvl dest_lvl - = getUniqueUs `thenLvl` \ uniq -> + = ASSERT( isId v ) + getUniqueUs `thenLvl` \ uniq -> let v' = setVarUnique v uniq v'' = subst_id_info env ctxt_lvl dest_lvl v' @@ -686,7 +685,8 @@ cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEn cloneVars TopLevel env vs ctxt_lvl dest_lvl = returnUs (env, vs) -- Don't clone top level things cloneVars NotTopLevel env vs ctxt_lvl dest_lvl - = getUniquesUs (length vs) `thenLvl` \ uniqs -> + = ASSERT( all isId vs ) + getUniquesUs (length vs) `thenLvl` \ uniqs -> let vs' = zipWith setVarUnique vs uniqs vs'' = map (subst_id_info env' ctxt_lvl dest_lvl) vs' diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 754f7deb06..4d2d4fda98 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -44,7 +44,6 @@ import Name ( mkLocalName, tidyOccName, tidyTopName, NamedThing(..), OccName ) import TyCon ( TyCon, isDataTyCon ) -import PrelRules ( builtinRules ) import Type ( Type, isUnLiftedType, tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars, @@ -94,11 +93,8 @@ core2core core_todos binds rules better_local_rules <- simplRules ru_us local_rules binds - let all_imported_rules = builtinRules ++ imported_rules - -- Here is where we add in the built-in rules - let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules - imported_rule_base = prepareOrphanRuleBase all_imported_rules + imported_rule_base = prepareOrphanRuleBase imported_rules -- Do the main business (stats, processed_binds, processed_local_rules) @@ -205,6 +201,8 @@ simplRules us rules binds bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds +simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _)) + = returnSmpl rule simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs)) | not is_local = returnSmpl rule -- No need to fiddle with imported rules diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index f09d6aeb0a..34ee7d6115 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -35,8 +35,9 @@ import Maybes ( maybeToBool, catMaybes ) import Name ( isLocalName, setNameUnique ) import SimplMonad import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType, - splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys + splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys ) +import TyCon ( tyConDataConsIfAvailable ) import PprType ( {- instance Outputable Type -} ) import DataCon ( dataConRepArity ) import TysPrim ( statePrimTyCon ) @@ -288,11 +289,16 @@ discardInline cont = cont -- Note the repType: we want to look through newtypes for this purpose -canUpdateInPlace ty = case splitAlgTyConApp_maybe (repType ty) of - Just (_, _, [dc]) -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc +canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of { + Nothing -> False ; + Just (tycon, _) -> + + case tyConDataConsIfAvailable tycon of + [dc] -> arity == 1 || arity == 2 + where + arity = dataConRepArity dc other -> False + } \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 92bb34c850..24eea0f25d 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -30,7 +30,7 @@ import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe, idOccInfo, setIdOccInfo, zapLamIdInfo, zapFragileIdInfo, idStrictness, isBottomingId, - setInlinePragma, mayHaveNoBinding, + setInlinePragma, setOneShotLambda, maybeModifyIdInfo ) import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), @@ -42,9 +42,8 @@ import Demand ( Demand, isStrict, wwLazy ) import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity, dataConSig, dataConArgTys ) -import Name ( isLocallyDefined ) import CoreSyn -import CoreFVs ( exprFreeVars ) +import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate, callSiteInline, hasSomeUnfolding, noUnfolding ) @@ -63,7 +62,9 @@ import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType, import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr, substEnv, isInScope, lookupIdSubst, substIdInfo ) -import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) +import TyCon ( isDataTyCon, tyConDataConsIfAvailable, + tyConClass_maybe, tyConArity, isDataTyCon + ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isLoopBreaker ) @@ -732,11 +733,8 @@ simplVar var cont case lookupIdSubst subst var of DoneEx e -> zapSubstEnv (simplExprF e cont) ContEx env1 e -> setSubstEnv env1 (simplExprF e cont) - DoneId var1 occ -> WARN( not (isInScope var1 subst) && isLocallyDefined var1 && not (mayHaveNoBinding var1), + DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1, text "simplVar:" <+> ppr var ) - -- The mayHaveNoBinding test accouunts for the fact - -- that class dictionary constructors dont have top level - -- bindings and hence aren't in scope. zapSubstEnv (completeCall var1 occ cont) -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1358,7 +1356,7 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts [] -> alts other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)] - missing_cons = [data_con | data_con <- tyConDataCons tycon, + missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon, not (data_con `elem` handled_data_cons)] handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++ [data_con | (DataAlt data_con, _, _) <- filtered_alts] diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 9d77aaf56b..6e7c6c233d 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -14,11 +14,11 @@ module Rules ( #include "HsVersions.h" import CoreSyn -- All of it -import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails ) +import OccurAnal ( occurAnalyseRule ) import BinderInfo ( markMany ) -import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars ) +import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) -import CoreUtils ( eqExpr, cheapEqExpr ) +import CoreUtils ( eqExpr ) import PprCore ( pprCoreRule ) import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, mkSubst, substEnv, setSubstEnv, emptySubst, isInScope, @@ -28,7 +28,6 @@ import Id ( Id, idUnfolding, zapLamIdInfo, idSpecialisation, setIdSpecialisation, setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo ) -import IdInfo ( setSpecInfo, specInfo ) import Name ( Name, isLocallyDefined ) import Var ( isTyVar, isId ) import VarSet @@ -407,32 +406,30 @@ addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better -addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs) - = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs) +addRule id (Rules rules rhs_fvs) rule + = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) where - new_rule = Rule str tpl_vars' tpl_args rhs' - -- Add occ info to tpl_vars, rhs - - (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs - (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars - - insert [] = [new_rule] - insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) - | otherwise = rule : insert rules - - new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) - - tpl_var_set = mkVarSet tpl_vars' - -- Actually we should probably include the free vars of tpl_args, - -- but I can't be bothered - - new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id + new_rule = occurAnalyseRule rule + new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id -- Hack alert! -- Don't include the Id in its own rhs free-var set. -- Otherwise the occurrence analyser makes bindings recursive -- that shoudn't be. E.g. -- RULE: f (f x y) z ==> f x (f y z) +insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) + = go rules + where + tpl_var_set = mkVarSet tpl_vars + -- Actually we should probably include the free vars of tpl_args, + -- but I can't be bothered + + go [] = [new_rule] + go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) + | otherwise = rule : go rules + + new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) + addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id addIdSpecialisations id spec_stuff = setIdSpecialisation id new_rules @@ -457,7 +454,7 @@ data ProtoCoreRule CoreRule -- The rule itself -pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule +pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (ppr fn) rule lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) lookupRule in_scope fn args diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 24a8b619cc..ccf1cee496 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -22,7 +22,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN, mkForAllTys, boxedTypeKind ) import PprType ( {- instance Outputable Type -} ) -import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList, +import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, substId, substAndCloneId, substAndCloneIds, lookupIdSubst ) import Var ( TyVar, mkSysTyVar, setVarUnique ) @@ -595,9 +595,16 @@ specProgram us binds return binds' where + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + top_subst = mkSubst (mkVarSet (bindersOfBinds binds)) emptySubstEnv + go [] = returnSM ([], emptyUDs) go (bind:binds) = go binds `thenSM` \ (binds', uds) -> - specBind emptySubst bind uds `thenSM` \ (bind', uds') -> + specBind top_subst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') dump_specs var = pprCoreRules var (idSpecialisation var) @@ -664,6 +671,7 @@ specExpr subst (Case scrut case_bndr alts) returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts) where (subst_alt, case_bndr') = substId subst case_bndr + -- No need to clone case binder; it can't float like a let(rec) spec_alt (con, args, rhs) = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) -> diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index bec1d11fcd..32b3469993 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -21,12 +21,13 @@ import CoreUnfold ( Unfolding, maybeUnfoldingTemplate ) import Id ( Id, idType, idArity, idStrictness, idUnfolding, isDataConId_maybe ) import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, - wwUnpackNew ) +import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, wwUnpackNew, + mkStrictnessInfo, isLazy + ) import SaLib import TyCon ( isProductTyCon, isRecursiveTyCon, isEnumerationTyCon, isNewTyCon ) import BasicTypes ( Arity, NewOrData(..) ) -import Type ( splitAlgTyConApp_maybe, +import Type ( splitTyConApp_maybe, isUnLiftedType, Type ) import TyCon ( tyConUnique ) import PrelInfo ( numericTyKeys ) @@ -602,7 +603,7 @@ findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) -- HOWEVER, if we make diverging functions appear lazy, they -- don't get wrappers, and then we get dreadful reboxing. -- See notes with WwLib.worthSplitting - = StrictnessInfo (combineDemands id str_ds abs_ds) (isBot str_res) + = find_strictness id str_ds str_res abs_ds findStrictness id str_val abs_val = NoStrictnessInfo @@ -616,14 +617,20 @@ findStrictness id str_val abs_val = NoStrictnessInfo -- Here the strictness value takes three args, but the absence value -- takes only one, for reasons I don't quite understand (see cheapFixpoint) -combineDemands id orig_str_ds orig_abs_ds - = go orig_str_ds orig_abs_ds +find_strictness id orig_str_ds orig_str_res orig_abs_ds + = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot) where + res_bot = isBot orig_str_res + go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy) - mk_dmd str_dmd (WwLazy True) = WARN( case str_dmd of { WwLazy _ -> False; other -> True }, - ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) - WwLazy True -- Best of all + mk_dmd str_dmd (WwLazy True) + = WARN( not (res_bot || isLazy str_dmd), + ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) + -- If the arg isn't used we jolly well don't expect the function + -- to be strict in it. Unless the function diverges. + WwLazy True -- Best of all + mk_dmd (WwUnpack nd u str_ds) (WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds) @@ -733,12 +740,9 @@ findRecDemand str_fn abs_fn ty where is_numeric_type ty - = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above - Nothing -> False - Just (tycon, _, _) - | tyConUnique tycon `is_elem` numericTyKeys - -> True - _{-something else-} -> False + = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above + Nothing -> False + Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys where is_elem = isIn "is_numeric_type" diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 5fcb8d7db9..9083d37f81 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -22,7 +22,7 @@ import DataCon ( DataCon, splitProductType ) import Demand ( Demand(..), wwLazy, wwPrim ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) -import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon ) +import TysWiredIn ( tupleCon ) import Type ( isUnLiftedType, splitForAllTys, splitFunTys, isAlgType, splitNewType_maybe, @@ -30,7 +30,7 @@ import Type ( isUnLiftedType, Type ) import TyCon ( isNewTyCon, isProductTyCon, TyCon ) -import BasicTypes ( NewOrData(..), Arity ) +import BasicTypes ( NewOrData(..), Arity, Boxity(..) ) import Var ( TyVar, Var, isId ) import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, mapUs, UniqSM ) @@ -497,7 +497,7 @@ mkWWcpr body_ty ReturnsCPR let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) arg_vars = map Var args - ubx_tup_con = unboxedTupleCon n_con_args + ubx_tup_con = tupleCon Unboxed n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index f00e8a1418..9d96872679 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -50,7 +50,7 @@ import TcType ( TcThetaType, zonkTcThetaType ) import Bag -import Class ( classInstEnv, Class ) +import Class ( classInstEnv, Class, FunDep ) import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) @@ -176,7 +176,7 @@ data Inst | FunDep Class -- the class from which this arises - [([TcType], [TcType])] + [FunDep TcType] InstLoc data OverloadedLit @@ -193,48 +193,25 @@ maps to do their stuff. \begin{code} instance Ord Inst where compare = cmpInst -instance Ord PredType where - compare = cmpPred instance Eq Inst where (==) i1 i2 = case i1 `cmpInst` i2 of EQ -> True other -> False -instance Eq PredType where - (==) p1 p2 = case p1 `cmpPred` p2 of - EQ -> True - other -> False -cmpInst (Dict _ pred1 _) (Dict _ pred2 _) - = (pred1 `cmpPred` pred2) -cmpInst (Dict _ _ _) other - = LT - -cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) - = GT -cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) - = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) -cmpInst (Method _ _ _ _ _ _) other - = LT - -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) - = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) -cmpInst (LitInst _ _ _ _) (FunDep _ _ _) - = LT -cmpInst (LitInst _ _ _ _) other - = GT - -cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) - = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) -cmpInst (FunDep _ _ _) other - = GT - -cmpPred (Class c1 tys1) (Class c2 tys2) - = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2) -cmpPred (IParam n1 ty1) (IParam n2 ty2) - = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2) -cmpPred (Class _ _) (IParam _ _) = LT -cmpPred _ _ = GT +cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2) +cmpInst (Dict _ _ _) other = LT + +cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT +cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) +cmpInst (Method _ _ _ _ _ _) other = LT + +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ _ _ _) (FunDep _ _ _) = LT +cmpInst (LitInst _ _ _ _) other = GT + +cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) +cmpInst (FunDep _ _ _) other = GT cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 @@ -400,10 +377,11 @@ newMethod orig id tys newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst -> returnNF_Tc (unitLIE meth_inst, instToId meth_inst) -instOverloadedFun orig (HsVar v) arg_tys theta tau +instOverloadedFun orig v arg_tys theta tau +-- This is where we introduce new functional dependencies into the LIE = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst -> instFunDeps orig theta `thenNF_Tc` \ fds -> - returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds)) + returnNF_Tc (instToId inst, mkLIE (inst : fds)) instFunDeps orig theta = tcGetInstLoc orig `thenNF_Tc` \ loc -> diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 92a82b5d79..52f1840ade 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,7 @@ import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), ) import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId, - tcLookupTyCon, + tcLookupTyConByKey, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) @@ -42,8 +42,6 @@ import TcType ( TcType, TcThetaType, ) import TcUnify ( unifyTauTy, unifyTauTyLists ) -import PrelInfo ( main_NAME, ioTyCon_NAME ) - import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars ) import Var ( idType, idName ) import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) @@ -62,6 +60,7 @@ import Util ( isIn ) import Maybes ( maybeToBool ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel ) import FiniteMap ( listToFM, lookupFM ) +import Unique ( ioTyConKey, mainKey, hasKey, Uniquable(..) ) import SrcLoc ( SrcLoc ) import Outputable \end{code} @@ -541,13 +540,20 @@ getTyVarsToGen is_unrestricted mono_id_tys lie zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> let body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars + fds = getAllFunDepsOfLIE lie in if is_unrestricted then - let fds = getAllFunDepsOfLIE lie in + -- We need to augment the type variables that appear explicitly in + -- the type by those that are determined by the functional dependencies. + -- e.g. suppose our type is C a b => a -> a + -- with the fun-dep a->b + -- Then we should generalise over b too; otherwise it will be + -- reported as ambiguous. zonkFunDeps fds `thenNF_Tc` \ fds' -> - let tvFundep = tyVarFunDep fds' - extended_tyvars = oclose tvFundep body_tyvars in + let tvFundep = tyVarFunDep fds' + extended_tyvars = oclose tvFundep body_tyvars + in -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $ returnNF_Tc (emptyVarSet, extended_tyvars) else @@ -734,7 +740,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs | main_bound_here = -- First unify the main_id with IO t, for any old t tcSetErrCtxt mainTyCheckCtxt ( - tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon -> + tcLookupTyConByKey ioTyConKey `thenTc` \ ioTyCon -> newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> unifyTauTy ((mkTyConApp ioTyCon [t_tv])) (idType main_mono_id) @@ -808,8 +814,8 @@ checkSigMatch top_lvl binder_names mono_ids sigs find_main NotTopLevel binder_names mono_ids = Nothing find_main TopLevel binder_names mono_ids = go binder_names mono_ids go [] [] = Nothing - go (n:ns) (m:ms) | n == main_NAME = Just m - | otherwise = go ns ms + go (n:ns) (m:ms) | n `hasKey` mainKey = Just m + | otherwise = go ns ms \end{code} @@ -936,13 +942,13 @@ sigContextsCtxt s1 s2 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) mainContextsErr id - | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded") + | id `hasKey` mainKey = ptext SLIT("Main.main cannot be overloaded") | otherwise = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings. mainTyCheckCtxt - = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME), + = hsep [ptext SLIT("When checking that"), quotes (ptext SLIT("main")), ptext SLIT("has the required type")] ----------------------------------------------- diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index a046545416..8e38983d12 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -13,7 +13,7 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBin import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSs(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), - pprHsClassAssertion, mkSimpleMatch, + mkSimpleMatch, andMonoBinds, andMonoBindList, getTyVarName, isClassDecl, isClassOpSig, isPragSig, collectMonoBinders ) @@ -27,7 +27,7 @@ import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, - tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, + tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) @@ -117,7 +117,7 @@ kcClassDecl (ClassDecl context class_name (classArityErr class_name) `thenTc_` -- Get the (mutable) class kind - tcLookupTy class_name `thenNF_Tc` \ (kind, _, _) -> + tcLookupTy class_name `thenNF_Tc` \ (kind, _) -> -- Make suitable tyvars and do kind checking -- The net effect is to mutate the class kind @@ -145,7 +145,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs tyvar_names fundeps class_sigs def_methods pragmas tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) = -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) -> + tcLookupTy class_name `thenTc` \ (class_kind, AClass rec_class arity) -> tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ -> -- The class kind is by now immutable @@ -201,7 +201,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs clas -- Yes! It's a dictionary new_or_data in - returnTc clas + returnTc (class_name, AClass clas arity) \end{code} \begin{code} @@ -211,10 +211,8 @@ tc_fundep (us, vs) = mapTc tc_fd_tyvar vs `thenTc` \ vs' -> returnTc (us', vs') tc_fd_tyvar v = - tcLookupTy v `thenTc` \(_, _, thing) -> - case thing of - ATyVar tv -> returnTc tv - -- ZZ else should fail more gracefully + tcLookupTy v `thenTc` \(_, ATyVar tv) -> + returnTc tv \end{code} \begin{code} @@ -248,11 +246,11 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names returnTc (sc_theta', sc_tys, sc_sel_ids) where - check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys) - (superClassErr class_name (c, tys)) + check_constraint sc@(HsPClass c tys) = checkTc (all is_tyvar tys) + (superClassErr class_name sc) - is_tyvar (MonoTyVar _) = True - is_tyvar other = False + is_tyvar (HsTyVar _) = True + is_tyvar other = False tcClassSig :: ValueEnv -- Knot tying only! @@ -342,7 +340,7 @@ tcClassDecl2 (ClassDecl context class_name | otherwise -- It is locally defined = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc src_loc $ - tcLookupClass class_name `thenNF_Tc` \ clas -> + tcLookupTy class_name `thenNF_Tc` \ (_, AClass clas _) -> tcDefaultMethodBinds clas default_binds class_sigs \end{code} @@ -642,7 +640,7 @@ classArityErr class_name = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name) superClassErr class_name sc - = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc) + = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc) <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) defltMethCtxt class_name diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index efa3e3de7b..58c39805ba 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -41,7 +41,7 @@ import Name ( isLocallyDefined, getSrcLoc, OccName, nameOccName ) import RdrName ( RdrName ) -import RnMonad ( Fixities ) +import RnMonad ( FixityEnv ) import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, @@ -188,7 +188,7 @@ context to the instance decl. The "offending classes" are \begin{code} tcDeriving :: ModuleName -- name of module under scrutiny - -> Fixities -- for the deriving code (Show/Read.) + -> FixityEnv -- for the deriving code (Show/Read.) -> RnNameSupply -- for "renaming" bits of generated code -> Bag InstInfo -- What we already know about instances -> TcM s (Bag InstInfo, -- The generated "instance decls". @@ -352,14 +352,12 @@ makeDerivEqns ------------------------------------------------------------------ chk_out :: Class -> TyCon -> Maybe Message chk_out clas tycon - | clas_key == enumClassKey && not is_enumeration = bog_out nullary_why - | clas_key == boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why - | clas_key == ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why + | clas `hasKey` enumClassKey && not is_enumeration = bog_out nullary_why + | clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why + | clas `hasKey` ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why | any isExistentialDataCon (tyConDataCons tycon) = Just (existentialErr clas tycon) | otherwise = Nothing where - clas_key = classKey clas - is_enumeration = isEnumerationTyCon tycon is_single_con = maybeToBool (maybeTyConSingleCon tycon) is_enumeration_or_single = is_enumeration || is_single_con @@ -555,13 +553,13 @@ the renamer. What a great hack! -- Generate the method bindings for the required instance -- (paired with class name, as we need that when generating dict -- names.) -gen_bind :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds) +gen_bind :: FixityEnv -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds) gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _) | not from_here = (clas_nm, tycon_nm, EmptyMonoBinds) - | ckey == showClassKey + | clas `hasKey` showClassKey = (clas_nm, tycon_nm, gen_Show_binds fixities tycon) - | ckey == readClassKey + | clas `hasKey` readClassKey = (clas_nm, tycon_nm, gen_Read_binds fixities tycon) | otherwise = (clas_nm, tycon_nm, @@ -572,15 +570,13 @@ gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _) ,(boundedClassKey, gen_Bounded_binds) ,(ixClassKey, gen_Ix_binds) ] - ckey + (classKey clas) tycon) where clas_nm = nameOccName (getName clas) tycon_nm = nameOccName (getName tycon) from_here = isLocallyDefined tycon (tycon,_,_) = splitAlgTyConApp ty - ckey = classKey clas - gen_inst_info :: InstInfo -> (Name, RenamedMonoBinds) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8e546feab2..d07c219b46 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -5,15 +5,15 @@ module TcEnv( TcEnv, ValueEnv, TcTyThing(..), - initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons, + initEnv, getEnvTyCons, getEnvClasses, getEnvAllTyCons, tcExtendUVarEnv, tcLookupUVar, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars, tcLookupTy, - tcLookupTyCon, tcLookupTyConByKey, - tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe, + tcLookupTyConByKey, + tcLookupClassByKey, tcLookupClassByKey_maybe, tcExtendGlobalValEnv, tcExtendLocalValEnv, tcGetValueEnv, tcSetValueEnv, @@ -32,7 +32,7 @@ module TcEnv( #include "HsVersions.h" -import HsTypes ( HsTyVar, getTyVarName ) +import HsTypes ( HsTyVarBndr, getTyVarName ) import Id ( mkUserLocal, isDataConWrapId_maybe ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, setVarName, @@ -150,7 +150,7 @@ data TcEnv = TcEnv type NameEnv val = UniqFM val -- Keyed by Names type UsageEnv = NameEnv UVar -type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing) +type TypeEnv = NameEnv (TcKind, TcTyThing) type ValueEnv = NameEnv Id valueEnvIds :: ValueEnv -> [Id] @@ -159,20 +159,29 @@ valueEnvIds ve = eltsUFM ve data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable -- if the kind is mutable, the tyvar must be so that -- zonking works - | ATyCon TyCon - | AClass Class + | ADataTyCon TyCon + | ASynTyCon TyCon Arity + | AClass Class Arity initEnv :: TcRef TcTyVarSet -> TcEnv initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut) -getEnvTyCons (TcEnv _ te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te] -getEnvClasses (TcEnv _ te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te] -getAllEnvTyCons (TcEnv _ te _ _) = catMaybes (map gettc (eltsUFM te)) +getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- eltsUFM te] + +getEnvTyCons (TcEnv _ te _ _) = catMaybes (map get_tc (eltsUFM te)) + where + get_tc (_, ADataTyCon tc) = Just tc + get_tc (_, ASynTyCon tc _) = Just tc + get_tc other = Nothing + +getEnvAllTyCons te_list = catMaybes (map get_tc te_list) + -- The 'all' means 'including the tycons from class decls' where - gettc (_,_, ATyCon tc) = Just tc - gettc (_,_, AClass cl) = Just (classTyCon cl) - gettc _ = Nothing + get_tc (_, ADataTyCon tc) = Just tc + get_tc (_, ASynTyCon tc _) = Just tc + get_tc (_, AClass cl _) = Just (classTyCon cl) + get_tc other = Nothing \end{code} The UsageEnv @@ -209,7 +218,7 @@ tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r tcExtendTyVarEnv tyvars scope = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) -> let - extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv)) + extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv)) | tv <- tyvars ] te' = addListToUFM te extend_list @@ -239,7 +248,7 @@ tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside in tcSetEnv (TcEnv ue te' ve gtvs) thing_inside where - stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv)) + stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv)) | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars ] @@ -282,9 +291,9 @@ tcGetInScopeTyVars Type constructors and classes \begin{code} -tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r +tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r tcExtendTypeEnv bindings scope - = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] ) + = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] ) -- Not for tyvars; use tcExtendTyVarEnv tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> let @@ -297,7 +306,7 @@ tcExtendTypeEnv bindings scope Looking up in the environments. \begin{code} -tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing) +tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing) tcLookupTy name = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM te name of { @@ -305,46 +314,35 @@ tcLookupTy name Nothing -> case maybeWiredInTyConName name of - Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc) - where - maybe_arity | isSynTyCon tc = Just (tyConArity tc) - | otherwise = Nothing + Just tc | isSynTyCon tc -> returnNF_Tc (kindToTcKind (tyConKind tc), ASynTyCon tc (tyConArity tc)) + | otherwise -> returnNF_Tc (kindToTcKind (tyConKind tc), ADataTyCon tc) Nothing -> -- This can happen if an interface-file -- unfolding is screwed up failWithTc (tyNameOutOfScope name) } -tcLookupClass :: Name -> NF_TcM s Class -tcLookupClass name - = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) -> - returnNF_Tc clas - -tcLookupTyCon :: Name -> NF_TcM s TyCon -tcLookupTyCon name - = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) -> - returnNF_Tc tycon - tcLookupClassByKey :: Unique -> NF_TcM s Class tcLookupClassByKey key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM_Directly te key of - Just (_, _, AClass cl) -> returnNF_Tc cl - other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) + Just (_, AClass cl _) -> returnNF_Tc cl + other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class) tcLookupClassByKey_maybe key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM_Directly te key of - Just (_, _, AClass cl) -> returnNF_Tc (Just cl) - other -> returnNF_Tc Nothing + Just (_, AClass cl _) -> returnNF_Tc (Just cl) + other -> returnNF_Tc Nothing tcLookupTyConByKey :: Unique -> NF_TcM s TyCon tcLookupTyConByKey key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM_Directly te key of - Just (_, _, ATyCon tc) -> returnNF_Tc tc - other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key) + Just (_, ADataTyCon tc) -> returnNF_Tc tc + Just (_, ASynTyCon tc _) -> returnNF_Tc tc + other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index e556db187c..2bb3060185 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -32,7 +32,7 @@ import TcEnv ( tcInstId, tcLookupValue, tcLookupClassByKey, tcLookupValueByKey, tcExtendGlobalTyVars, tcLookupValueMaybe, - tcLookupTyCon, tcLookupDataCon + tcLookupTyConByKey, tcLookupDataCon ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) @@ -72,13 +72,11 @@ import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy ) import TysWiredIn ( boolTy, charTy, stringTy ) -import PrelInfo ( ioTyCon_NAME ) -import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy, - unifyUnboxedTupleTy ) +import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) import Unique ( cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, - thenMClassOpKey, failMClassOpKey, returnMClassOpKey + thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey ) import Outputable import Maybes ( maybeToBool, mapMaybe ) @@ -359,7 +357,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty = -- Get the callable and returnable classes. tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass -> - tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon -> + tcLookupTyConByKey ioTyConKey `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) @@ -462,15 +460,12 @@ tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list = tcAddErrCtxt (listCtxt expr) $ tcMonoExpr expr elt_ty -tcMonoExpr (ExplicitTuple exprs boxed) res_ty - = (if boxed - then unifyTupleTy (length exprs) res_ty - else unifyUnboxedTupleTy (length exprs) res_ty - ) `thenTc` \ arg_tys -> +tcMonoExpr (ExplicitTuple exprs boxity) res_ty + = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys -> mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty) (exprs `zip` arg_tys) -- we know they're of equal length. `thenTc` \ (exprs', lies) -> - returnTc (ExplicitTuple exprs' boxed, plusLIEs lies) + returnTc (ExplicitTuple exprs' boxity, plusLIEs lies) tcMonoExpr expr@(RecordCon con_name rbinds) res_ty = tcAddErrCtxt (recordConCtxt expr) $ @@ -897,11 +892,11 @@ tcId name tcLookupValueMaybe name `thenNF_Tc` \ maybe_local -> case maybe_local of - Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id)) + Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id)) Nothing -> tcLookupValue name `thenNF_Tc` \ id -> tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) -> - instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau + instantiate_it2 (OccurrenceOf id) id tyvars theta tau where -- The instantiate_it loop runs round instantiating the Id. @@ -917,7 +912,7 @@ tcId name instantiate_it2 orig fun tyvars theta tau = if null theta then -- Is it overloaded? - returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau) + returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau) else -- Yes, it's overloaded instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) -> diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index e814e06386..aa2434704a 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -207,7 +207,7 @@ checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s () checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) - | (getUnique io) == ioTyConKey && pred_res_ty res_ty + | io `hasKey` ioTyConKey && pred_res_ty res_ty -> returnTc () _ -> check (non_io_result_ok && pred_res_ty ty) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 20e59ebefc..d216ae6409 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -33,9 +33,10 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), ) import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkSrcUnqual ) -import RnMonad ( Fixities ) +import RnMonad ( FixityEnv, lookupFixity ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) , maxPrecedence, defaultFixity + , Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, @@ -648,7 +649,7 @@ gen_Ix_binds tycon enum_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $ + [TuplePatIn [a_Pat, b_Pat] Boxed] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ @@ -658,7 +659,7 @@ gen_Ix_binds tycon enum_index = mk_easy_FunMonoBind tycon_loc index_RDR - [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] True{-boxed-}), + [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed), d_Pat] [] ( HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( @@ -678,7 +679,7 @@ gen_Ix_binds tycon enum_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -715,7 +716,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $ + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $ HsDo ListComp stmts tycon_loc where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -724,45 +725,45 @@ gen_Ix_binds tycon mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) tycon_loc ---------------- single_con_index = mk_easy_FunMonoBind tycon_loc index_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [range_size] ( foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) = genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i)) ) plus_RDR ( genOpApp ( (HsApp (HsVar rangeSize_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) ) times_RDR multiply_by ) range_size = mk_easy_FunMonoBind tycon_loc rangeSize_RDR - [TuplePatIn [a_Pat, b_Pat] True] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed] [] ( genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr) + (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr) ) plus_RDR (HsLit (HsInt 1))) ------------------ single_con_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [] ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where in_range a b c = HsApp (HsApp (HsVar inRange_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) (HsVar c) \end{code} @@ -773,9 +774,9 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixities tycon +gen_Read_binds fixity_env tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -822,25 +823,25 @@ gen_Read_binds fixities tycon con_qual | not is_infix = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed) (HsApp (HsVar lex_RDR) c_Expr) tycon_loc | otherwise = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed) (HsApp (HsVar lex_RDR) (HsVar bs1)) tycon_loc str_qual str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (HsVar lex_RDR) draw_from) tycon_loc str_qual_paren str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from) tycon_loc @@ -895,15 +896,15 @@ gen_Read_binds fixities tycon mk_read_qual p con_field res draw_from = BindStmt - (TuplePatIn [VarPatIn con_field, VarPatIn res] True) + (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed) (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from) tycon_loc result_expr = ExplicitTuple [con_expr, if null bs_needed then d_Expr - else HsVar (last bs_needed)] True + else HsVar (last bs_needed)] Boxed - [lp,rp] = getLRPrecs is_infix fixities dc_nm + [lp,rp] = getLRPrecs is_infix fixity_env dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -916,7 +917,7 @@ gen_Read_binds fixities tycon -} paren_prec_limit | not is_infix = fromInt maxPrecedence - | otherwise = getFixity fixities dc_nm + | otherwise = getFixity fixity_env dc_nm read_paren_arg -- parens depend on precedence... | nullary_con = false_Expr -- it's optional. @@ -930,9 +931,9 @@ gen_Read_binds fixities tycon %************************************************************************ \begin{code} -gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixs_assoc tycon +gen_Show_binds fixity_env tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -1003,7 +1004,7 @@ gen_Show_binds fixs_assoc tycon mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs is_infix fixs_assoc dc_nm + prec_cons = getLRPrecs is_infix fixity_env dc_nm real_show_thingies | is_infix = @@ -1024,27 +1025,27 @@ gen_Show_binds fixs_assoc tycon (map show_label labels) real_show_thingies - (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm + (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env dc_nm {- c.f. Figure 16 and 17 in Haskell 1.1 report -} paren_prec_limit | not is_infix = fromInt maxPrecedence + 1 - | otherwise = getFixity fixs_assoc dc_nm + 1 + | otherwise = getFixity fixity_env dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Bool -> Fixities -> Name -> [Integer] -getLRPrecs is_infix fixs_assoc nm = [lp, rp] +getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer] +getLRPrecs is_infix fixity_env nm = [lp, rp] where {- Figuring out the fixities of the arguments to a constructor, cf. Figures 16-18 in Haskell 1.1 report. -} - (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm - paren_con_prec = getFixity fixs_assoc nm + (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm + paren_con_prec = getFixity fixity_env nm maxPrec = fromInt maxPrecedence lp @@ -1057,27 +1058,22 @@ getLRPrecs is_infix fixs_assoc nm = [lp, rp] | con_right_assoc = paren_con_prec | otherwise = paren_con_prec + 1 -getFixity :: Fixities -> Name -> Integer -getFixity fixs_assoc nm = - case lookupFixity fixs_assoc nm of - Fixity x _ -> fromInt x +getFixity :: FixityEnv -> Name -> Integer +getFixity fixity_env nm = case lookupFixity fixity_env nm of + Fixity x _ -> fromInt x -isLRAssoc :: Fixities -> Name -> (Bool, Bool) +isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) isLRAssoc fixs_assoc nm = case lookupFixity fixs_assoc nm of Fixity _ InfixN -> (False, False) Fixity _ InfixR -> (False, True) Fixity _ InfixL -> (True, False) -lookupFixity :: Fixities -> Name -> Fixity -lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm - isInfixOccName :: String -> Bool isInfixOccName str = case str of (':':_) -> True _ -> False - \end{code} @@ -1130,7 +1126,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) = mk_FunMonoBind (getSrcLoc tycon) rdr_name [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], ExprWithTySig (HsApp tagToEnum_Expr a_Expr) - (MonoTyVar (qual_orig_name tycon)))] + (HsTyVar (qual_orig_name tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mk_easy_FunMonoBind (getSrcLoc tycon) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index e99c01daf5..c45fab7501 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -655,15 +655,16 @@ zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs -zonkRule (RuleDecl name tyvars vars lhs rhs loc) +zonkRule (HsRule name tyvars vars lhs rhs loc) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs -> tcExtendGlobalValEnv new_bndrs $ zonkExpr lhs `thenNF_Tc` \ new_lhs -> zonkExpr rhs `thenNF_Tc` \ new_rhs -> - returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) + returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) -- I hate this map RuleBndr stuff -zonkRule (IfaceRuleDecl fun rule loc) - = returnNF_Tc (IfaceRuleDecl fun rule loc) +zonkRule (IfaceRuleOut fun rule) + = zonkIdOcc fun `thenNF_Tc` \ fun' -> + returnNF_Tc (IfaceRuleOut fun' rule) \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index cd5d05cac4..7f803d52c6 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), IfaceSig(..) ) +import HsSyn ( HsDecl(..), IfaceSig(..), HsTupCon(..) ) import TcMonad import TcMonoType ( tcHsType, tcHsTypeKind, -- NB: all the tyars in interface files are kinded, @@ -39,11 +39,10 @@ import Id ( Id, mkId, mkVanillaId, import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) -import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy ) +import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy ) import Var ( mkTyVar, tyVarKind ) import VarEnv import Name ( Name, NamedThing(..), isLocallyDefined ) -import Unique ( rationalTyConKey ) import TysWiredIn ( integerTy, stringTy ) import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) @@ -102,8 +101,8 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins in returnTc info2 - tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result))) - = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result) + tcPrag info (HsStrictness strict_info) + = returnTc (info `setStrictnessInfo` strict_info) tcPrag info (HsWorker nm) = tcWorkerInfo unf_env ty info nm @@ -214,7 +213,7 @@ tcCoreExpr (UfCCall cc ty) tcGetUnique `thenNF_Tc` \ u -> returnTc (Var (mkCCallOpId u cc ty')) -tcCoreExpr (UfTuple name args) +tcCoreExpr (UfTuple (HsTupCon name _) args) = tcVar name `thenTc` \ con_id -> mapTc tcCoreExpr args `thenTc` \ args' -> let @@ -332,16 +331,18 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs) +tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) = tcVar con_name `thenTc` \ con_id -> let - con = case isDataConWrapId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id) + con = case isDataConWrapId_maybe con_id of + Just con -> con + Nothing -> pprPanic "tcCoreAlt" (ppr con_id) (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con - (_, inst_tys, cons) = splitAlgTyConApp scrut_ty + (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of + Just stuff -> stuff + Nothing -> pprPanic "tcCoreAlt" (ppr alt) ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] ex_tys' = mkTyVarTys ex_tyvars' arg_tys = dataConArgTys con (inst_tys ++ ex_tys') diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs index 1451d44027..74f38b997d 100644 --- a/ghc/compiler/typecheck/TcImprove.lhs +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -4,14 +4,13 @@ module TcImprove ( tcImprove ) where #include "HsVersions.h" import Name ( Name ) -import Type ( Type, tyVarsOfTypes ) -import Class ( className, classInstEnv, classExtraBigSig ) +import Class ( Class, FunDep, className, classInstEnv, classExtraBigSig ) import Unify ( unifyTyListsX, matchTys ) import Subst ( mkSubst, substTy ) import TcMonad -import TcType ( zonkTcType, zonkTcTypes ) +import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes ) import TcUnify ( unifyTauTyLists ) -import Inst ( Inst, LookupInstResult(..), +import Inst ( LIE, Inst, LookupInstResult(..), lookupInst, getFunDepsOfLIE, getIPsOfLIE, zonkLIE, zonkFunDeps {- for debugging -} ) import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and @@ -24,65 +23,57 @@ import List ( elemIndex, nub ) \end{code} \begin{code} -tcImprove lie = - if null nfdss then - returnTc () - else - -- zonkCfdss cfdss `thenTc` \ cfdss' -> - -- pprTrace "tcI" (ppr cfdss') $ - iterImprove nfdss - where +tcImprove :: LIE -> TcM s () +-- Do unifications based on functional dependencies in the LIE +tcImprove lie + | null nfdss = returnTc () + | otherwise = iterImprove nfdss + where + nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])] + nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss + + cfdss :: [(Class, [FunDep TcType])] cfdss = getFunDepsOfLIE lie clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss + classes = nub (map fst cfdss) inst_nfdss = concatMap getInstNfdssOf classes + ips = getIPsOfLIE lie ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips - nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss -getInstNfdssOf clas = nfdss - where +{- Example: we have + class C a b c | a->b where ... + instance C Int Bool c + + Given the LIE FD C (Int->t) + we get clas_nfdss = [({}, C, [Int->t, t->Int]) + inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])] + + Another way would be to flatten a bit + we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)] + inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)] + + iterImprove then matches up the C and Int, and unifies t <-> Bool +-} + +getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])] +getInstNfdssOf clas + = [ (free, nm, instantiateFdClassTys clas ts) + | (free, ts, i) <- classInstEnv clas + ] + where nm = className clas - ins = classInstEnv clas - mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts) - nfdss = map mk_nfds ins -iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s () +iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s () iterImprove [] = returnTc () iterImprove cfdss - = -- zonkCfdss cfdss `thenTc` \ cfdss' -> - -- pprTrace "iterI" (ppr cfdss') $ - -- instImprove cfdss `thenTc` \ change1 -> - selfImprove pairImprove cfdss `thenTc` \ change2 -> + = selfImprove pairImprove cfdss `thenTc` \ change2 -> if {- change1 || -} change2 then iterImprove cfdss else returnTc () --- ZZ debugging... -zonkCfdss ((c, fds) : cfdss) - = zonkFunDeps fds `thenTc` \ fds' -> - zonkCfdss cfdss `thenTc` \ cfdss' -> - returnTc ((c, fds') : cfdss') -zonkCfdss [] = returnTc [] - -{- -instImprove (cfds@(clas, fds) : cfdss) - = instImprove1 cfds ins `thenTc` \ changed -> - instImprove cfdss `thenTc` \ rest_changed -> - returnTc (changed || rest_changed) - where ins = classInstEnv clas -instImprove [] = returnTc False - -instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins) - = -- pprTrace "iI1" (ppr (free, ts, i)) $ - checkFds fds1 free fds2 `thenTc` \ changed -> - instImprove1 cfds ins `thenTc` \ rest_changed -> - returnTc (changed || rest_changed) - where fds2 = instantiateFdClassTys clas ts -instImprove1 _ _ = returnTc False --} - -- ZZ this will do a lot of redundant checking wrt instances -- it would do to make this operate over two lists, the first -- with only clas_nfds and ip_nfds, and the second with everything @@ -90,12 +81,13 @@ instImprove1 _ _ = returnTc False -- caller could control whether the redundant inst improvements -- were avoided -- you could then also use this to check for consistency of new instances + +-- selfImprove is really just doing a cartesian product of all the fds selfImprove f [] = returnTc False selfImprove f (nfds : nfdss) = mapTc (f nfds) nfdss `thenTc` \ changes -> - anyTc changes `thenTc` \ changed -> selfImprove f nfdss `thenTc` \ rest_changed -> - returnTc (changed || rest_changed) + returnTc (or changes || rest_changed) pairImprove (free1, n1, fds1) (free2, n2, fds2) = if n1 == n2 then @@ -150,14 +142,6 @@ zonkUnifyTys free ts1 ts2 mapTc zonkTcType ts2 `thenTc` \ ts2' -> -- pprTrace "zMT" (ppr (ts1', free, ts2')) $ case unifyTyListsX free ts2' ts1' of - Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $ - returnTc (Just subst) - Nothing -> returnTc Nothing -\end{code} - -Utilities: - -A monadic version of the standard Prelude `or' function. -\begin{code} -anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs + Just subst -> returnTc (Just subst) + Nothing -> returnTc Nothing \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 882123f387..a140b9c832 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -19,7 +19,7 @@ import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, checkFromThisClass ) import TcMonad -import RnMonad ( RnNameSupply, Fixities ) +import RnMonad ( RnNameSupply, FixityEnv ) import Inst ( Inst, InstOrigin(..), newDicts, newClassDicts, LIE, emptyLIE, plusLIE, plusLIEs ) @@ -59,7 +59,7 @@ import Subst ( mkTopTyVarSubst, substClasses ) import VarSet ( mkVarSet, varSetElems ) import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy, isFFIArgumentTy, isFFIResultTy ) -import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) ) +import Unique ( Unique, cCallableClassKey, cReturnableClassKey, hasKey, Uniquable(..) ) import Outputable \end{code} @@ -140,7 +140,7 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids -> [RenamedHsDecl] -> ModuleName -- module name for deriving - -> Fixities + -> FixityEnv -> RnNameSupply -- for renaming derivings -> TcM s (Bag InstInfo, RenamedHsBinds) @@ -492,8 +492,8 @@ scrutiniseInstanceHead clas inst_taus | -- CCALL CHECK -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. - (getUnique clas == cCallableClassKey && not (ccallable_type first_inst_tau)) || - (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau)) + (clas `hasKey` cCallableClassKey && not (ccallable_type first_inst_tau)) || + (clas `hasKey` cReturnableClassKey && not (creturnable_type first_inst_tau)) = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau) -- DERIVING CHECK diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 14adb46edc..e21730a3be 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -13,6 +13,7 @@ module TcModule ( import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) +import HsTypes ( toHsType ) import RnHsSyn ( RenamedHsModule ) import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl, @@ -25,9 +26,9 @@ import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv, - getEnvTyCons, getEnvClasses, tcLookupValueMaybe, + getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe, explicitLookupValueByKey, tcSetValueEnv, - tcLookupTyCon, initEnv, valueEnvIds, + initEnv, ValueEnv, TcTyThing(..) ) import TcExpr ( tcId ) @@ -44,24 +45,23 @@ import TcType ( TcType, typeToTcType, newTyVarTy ) -import RnMonad ( RnNameSupply, getIfaceFixities, Fixities, InterfaceDetails ) +import RnMonad ( RnNameSupply, FixityEnv ) import Bag ( isEmptyBag ) import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet ) -import Id ( Id, idType ) +import Id ( Id, idType, idName ) import Module ( pprModuleName ) import OccName ( isSysOcc ) import Name ( Name, nameUnique, nameOccName, isLocallyDefined, - toRdrName, NamedThing(..) + toRdrName, nameEnvElts, NamedThing(..) ) import TyCon ( TyCon, tyConKind ) import Class ( Class, classSelIds, classTyCon ) import Type ( mkTyConApp, mkForAllTy, boxedTypeKind, getTyVar, Type ) import TysWiredIn ( unitTy ) -import PrelMods ( mAIN_Name ) -import PrelInfo ( main_NAME, thinAirIdNames, setThinAirIds ) +import PrelInfo ( mAIN_Name ) import TcUnify ( unifyTauTy ) -import Unique ( Unique ) +import Unique ( Unique, mainKey ) import UniqSupply ( UniqSupply ) import Maybes ( maybeToBool ) import Util @@ -83,33 +83,26 @@ data TcResults tc_insts :: Bag InstInfo, -- Instance declaration information tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. tc_rules :: [TypecheckedRuleDecl], -- Transformation rules - tc_env :: ValueEnv, - tc_thinair :: [Id] -- The thin-air Ids + tc_env :: ValueEnv } --------------- typecheckModule :: UniqSupply -> RnNameSupply - -> InterfaceDetails + -> FixityEnv -> RenamedHsModule -> IO (Maybe TcResults) -typecheckModule us rn_name_supply iface_det mod - = initTc us initEnv (tcModule rn_name_supply (getIfaceFixities iface_det) mod) - >>= \ (maybe_result, warns, errs) -> +typecheckModule us rn_name_supply fixity_env mod + = initTc us initEnv (tcModule rn_name_supply fixity_env mod) >>= \ (maybe_result, warns, errs) -> printErrorsAndWarnings errs warns >> - - -- write the thin-air Id map - (case maybe_result of - Just results -> setThinAirIds (tc_thinair results) - Nothing -> return () - ) >> - + (case maybe_result of Nothing -> return () - Just results -> dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) + Just results -> dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) >> + dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) ) >> return (if isEmptyBag errs then @@ -120,6 +113,22 @@ typecheckModule us rn_name_supply iface_det mod dump_tc results = ppr (tc_binds results) $$ pp_rules (tc_rules results) +dump_sigs results -- Print type signatures + = -- Convert to HsType so that we get source-language style printing + -- And sort by RdrName + vcat $ map ppr_sig $ sortLt lt_sig $ + [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results), + want_sig id + ] + where + lt_sig (n1,_) (n2,_) = n1 < n2 + ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t + + want_sig id | opt_PprStyle_Debug = True + | otherwise = isLocallyDefined n && not (isSysOcc (nameOccName n)) + where + n = idName id + pp_rules [] = empty pp_rules rs = vcat [ptext SLIT("{-# RULES"), nest 4 (vcat (map ppr rs)), @@ -129,12 +138,12 @@ pp_rules rs = vcat [ptext SLIT("{-# RULES"), The internal monster: \begin{code} tcModule :: RnNameSupply -- for renaming derivings - -> Fixities -- needed for Show/Read derivings. + -> FixityEnv -- needed for Show/Read derivings. -> RenamedHsModule -- input -> TcM s TcResults -- output tcModule rn_name_supply fixities - (HsModule mod_name verion exports imports decls _ src_loc) + (HsModule mod_name _ _ _ decls _ src_loc) = tcAddSrcLoc src_loc $ -- record where we're starting fixTc (\ ~(unf_env ,_) -> @@ -165,22 +174,42 @@ tcModule rn_name_supply fixities ) `thenTc` \ (_, env, inst_info, deriv_binds) -> tcSetEnv env ( + let + tycons = getEnvTyCons env + classes = getEnvClasses env + local_tycons = filter isLocallyDefined tycons + local_classes = filter isLocallyDefined classes + in -- Default declarations tcDefaults decls `thenTc` \ defaulting_tys -> tcSetDefaultTys defaulting_tys $ + -- Extend the TyCon envt with the tycons corresponding to + -- the classes. + -- They are mentioned in types in interface files. + tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), ADataTyCon tycon)) + | clas <- classes, + let tycon = classTyCon clas + ] $ + + -- Interface type signatures + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + -- We must do this before mkImplicitDataBinds (which comes next), since + -- the latter looks up unpackCStringId, for example, which is usually + -- imported + tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> + tcExtendGlobalValEnv sig_ids $ + -- Create any necessary record selector Ids and their bindings -- "Necessary" includes data and newtype declarations -- We don't create bindings for dictionary constructors; -- they are always fully applied, and the bindings are just there -- to support partial applications - let - tycons = getEnvTyCons env - classes = getEnvClasses env - local_tycons = filter isLocallyDefined tycons - local_classes = filter isLocallyDefined classes - in mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) -> mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> @@ -194,23 +223,6 @@ tcModule rn_name_supply fixities tcExtendGlobalValEnv data_ids $ tcExtendGlobalValEnv cls_ids $ - -- Extend the TyCon envt with the tycons corresponding to - -- the classes. - -- They are mentioned in types in interface files. - tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, ATyCon tycon)) - | clas <- classes, - let tycon = classTyCon clas - ] $ - - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - -- foreign import declarations next. tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> tcExtendGlobalValEnv fo_ids $ @@ -253,7 +265,7 @@ tcModule rn_name_supply fixities -- Check that Main defines main (if mod_name == mAIN_Name then - tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main -> + tcLookupValueByKeyMaybe mainKey `thenNF_Tc` \ maybe_main -> checkTc (maybeToBool maybe_main) noMainErr else returnTc () @@ -275,12 +287,6 @@ tcModule rn_name_supply fixities zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> zonkRules rules `thenNF_Tc` \ rules' -> - let - thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames - -- When looking up the thin-air names we must use - -- a global env that includes the zonked locally-defined Ids too - -- Hence using really_final_env - in returnTc (really_final_env, (TcResults { tc_binds = all_binds', tc_tycons = local_tycons, @@ -288,8 +294,7 @@ tcModule rn_name_supply fixities tc_insts = inst_info, tc_fords = foi_decls ++ foe_decls', tc_rules = rules', - tc_env = really_final_env, - tc_thinair = thin_air_ids + tc_env = really_final_env })) ) @@ -304,6 +309,6 @@ get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \begin{code} noMainErr = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name), - ptext SLIT("must include a definition for"), quotes (ppr main_NAME)] + ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 2745f78a6c..cb6c3be3e6 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -13,8 +13,8 @@ module TcMonoType ( tcHsType, tcHsSigType, tcHsTypeKind, tcHsTopType, tcHsTopBox #include "HsVersions.h" -import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..), - Sig(..), HsPred(..), pprHsPred, pprParendHsType ) +import HsSyn ( HsType(..), HsTyVarBndr(..), HsUsageAnn(..), + Sig(..), HsPred(..), pprParendHsType, HsTupCon(..) ) import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) @@ -48,14 +48,14 @@ import VarEnv import VarSet import Bag ( bagToList ) import ErrUtils ( Message ) -import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) import Name ( Name, OccName, isLocallyDefined ) -import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy ) +import TysWiredIn ( mkListTy, mkTupleTy ) import UniqFM ( elemUFM, foldUFM ) +import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) import Unique ( Unique, Uniquable(..) ) -import Util ( mapAccumL, isSingleton ) +import Util ( mapAccumL, isSingleton, removeDups ) import Outputable \end{code} @@ -153,49 +153,45 @@ tc_type ty returnTc tc_ty tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type) -tc_type_kind ty@(MonoTyVar name) +tc_type_kind ty@(HsTyVar name) = tc_app ty [] -tc_type_kind (MonoListTy ty) +tc_type_kind (HsListTy ty) = tc_boxed_type ty `thenTc` \ tau_ty -> returnTc (boxedTypeKind, mkListTy tau_ty) -tc_type_kind (MonoTupleTy tys True {-boxed-}) +tc_type_kind (HsTupleTy (HsTupCon _ Boxed) tys) = mapTc tc_boxed_type tys `thenTc` \ tau_tys -> - returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys) + returnTc (boxedTypeKind, mkTupleTy Boxed (length tys) tau_tys) -tc_type_kind (MonoTupleTy tys False {-unboxed-}) +tc_type_kind (HsTupleTy (HsTupCon _ Unboxed) tys) = mapTc tc_type tys `thenTc` \ tau_tys -> - returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys) + returnTc (unboxedTypeKind, mkTupleTy Unboxed (length tys) tau_tys) -tc_type_kind (MonoFunTy ty1 ty2) +tc_type_kind (HsFunTy ty1 ty2) = tc_type ty1 `thenTc` \ tau_ty1 -> tc_type ty2 `thenTc` \ tau_ty2 -> returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2) -tc_type_kind (MonoTyApp ty1 ty2) +tc_type_kind (HsAppTy ty1 ty2) = tc_app ty1 [ty2] -tc_type_kind (MonoIParamTy n ty) - = tc_type ty `thenTc` \ tau -> - returnTc (boxedTypeKind, mkPredTy (IParam n tau)) +tc_type_kind (HsPredTy pred) + = tcClassAssertion True pred `thenTc` \ pred' -> + returnTc (boxedTypeKind, mkPredTy pred') -tc_type_kind (MonoDictTy class_name tys) - = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) -> - returnTc (boxedTypeKind, mkDictTy clas arg_tys) - -tc_type_kind (MonoUsgTy usg ty) +tc_type_kind (HsUsgTy usg ty) = newUsg usg `thenTc` \ usg' -> tc_type_kind ty `thenTc` \ (kind, tc_ty) -> returnTc (kind, mkUsgTy usg' tc_ty) where newUsg usg = case usg of - MonoUsOnce -> returnTc UsOnce - MonoUsMany -> returnTc UsMany - MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv -> + HsUsOnce -> returnTc UsOnce + HsUsMany -> returnTc UsMany + HsUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv -> returnTc (UsVar uv) -tc_type_kind (MonoUsgForAllTy uv_name ty) +tc_type_kind (HsUsgForAllTy uv_name ty) = let uv = mkNamedUVar uv_name in @@ -217,12 +213,12 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty) -- f :: forall a. Num a => (# a->a, a->a #) -- And we want these to get through the type checker check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau) - where ct_vars = tyVarsOfTypes tys + where ct_vars = tyVarsOfTypes tys forall_tyvars = map varName in_scope_vars - tau_vars = tyVarsOfType tau - ambig ct_var = (varName ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` tau_vars) - ambiguous = foldUFM ((||) . ambig) False ct_vars + tau_vars = tyVarsOfType tau + ambig ct_var = (varName ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` tau_vars) + ambiguous = foldUFM ((||) . ambig) False ct_vars check _ = returnTc () in mapTc check theta `thenTc_` @@ -233,7 +229,7 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tc_app (MonoTyApp ty1 ty2) tys +tc_app (HsAppTy ty1 ty2) tys = tc_app ty1 (ty2:tys) tc_app ty tys @@ -257,16 +253,16 @@ tc_app ty tys -- But not quite; for synonyms it checks the correct arity, and builds a SynTy -- hence the rather strange functionality. -tc_fun_type (MonoTyVar name) arg_tys - = tcLookupTy name `thenTc` \ (tycon_kind, maybe_arity, thing) -> +tc_fun_type (HsTyVar name) arg_tys + = tcLookupTy name `thenTc` \ (tycon_kind, thing) -> case thing of - ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys) - AClass clas -> failWithTc (classAsTyConErr name) - ATyCon tc -> case maybe_arity of - Nothing -> -- Data or newtype - returnTc (tycon_kind, mkTyConApp tc arg_tys) + ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys) + AClass clas _ -> failWithTc (classAsTyConErr name) + + ADataTyCon tc -> -- Data or newtype + returnTc (tycon_kind, mkTyConApp tc arg_tys) - Just arity -> -- Type synonym + ASynTyCon tc arity -> -- Type synonym checkTc (arity <= n_args) err_msg `thenTc_` returnTc (tycon_kind, result_ty) where @@ -290,35 +286,14 @@ Contexts \begin{code} tcContext :: RenamedContext -> TcM s ThetaType -tcContext context - = --Someone discovered that @CCallable@ and @CReturnable@ - -- could be used in contexts such as: - -- foo :: CCallable a => a -> PrimIO Int - -- Doing this utterly wrecks the whole point of introducing these - -- classes so we specifically check that this isn't being done. - -- - -- We *don't* do this check in tcClassAssertion, because that's - -- called when checking a HsDictTy, and we don't want to reject - -- instance CCallable Int - -- etc. Ugh! - mapTc check_naughty context `thenTc_` - - mapTc tcClassAssertion context - - where - check_naughty (HsPClass class_name _) - = checkTc (not (getUnique class_name `elem` cCallishClassKeys)) - (naughtyCCallContextErr class_name) - check_naughty (HsPIParam _ _) = returnTc () - -tcClassAssertion assn@(HsPClass class_name tys) - = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $ - mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> - tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) -> +tcContext context = mapTc (tcClassAssertion False) context + +tcClassAssertion ccall_ok assn@(HsPClass class_name tys) + = tcAddErrCtxt (appKindCtxt (ppr assn)) $ + mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> + tcLookupTy class_name `thenTc` \ (kind, thing) -> case thing of - ATyVar _ -> failWithTc (tyVarAsClassErr class_name) - ATyCon _ -> failWithTc (tyConAsClassErr class_name) - AClass clas -> + AClass clas arity -> -- Check with kind mis-match checkTc (arity == n_tys) err `thenTc_` unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_` @@ -326,8 +301,10 @@ tcClassAssertion assn@(HsPClass class_name tys) where n_tys = length tys err = arityErr "Class" class_name arity n_tys -tcClassAssertion assn@(HsPIParam name ty) - = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $ + other -> failWithTc (tyVarAsClassErr class_name) + +tcClassAssertion ccall_ok assn@(HsPIParam name ty) + = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_type_kind ty `thenTc` \ (arg_kind, arg_ty) -> returnTc (IParam name arg_ty) \end{code} @@ -340,7 +317,7 @@ tcClassAssertion assn@(HsPIParam name ty) %************************************************************************ \begin{code} -tcExtendTopTyVarScope :: TcKind -> [HsTyVar Name] +tcExtendTopTyVarScope :: TcKind -> [HsTyVarBndr Name] -> ([TcTyVar] -> TcKind -> TcM s a) -> TcM s a tcExtendTopTyVarScope kind tyvar_names thing_inside @@ -354,14 +331,14 @@ tcExtendTopTyVarScope kind tyvar_names thing_inside mk_tv (IfaceTyVar name _, kind) = mkTyVar name kind -- NB: immutable tyvars, but perhaps with mutable kinds -tcExtendTyVarScope :: [HsTyVar Name] +tcExtendTyVarScope :: [HsTyVarBndr Name] -> ([TcTyVar] -> TcM s a) -> TcM s a tcExtendTyVarScope tv_names thing_inside = mapNF_Tc tcHsTyVar tv_names `thenNF_Tc` \ tyvars -> tcExtendTyVarEnv tyvars $ thing_inside tyvars -tcHsTyVar :: HsTyVar Name -> NF_TcM s TcTyVar +tcHsTyVar :: HsTyVarBndr Name -> NF_TcM s TcTyVar tcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind -> tcNewMutTyVar name kind -- NB: mutable kind => mutable tyvar, so that zonking can bind @@ -369,7 +346,7 @@ tcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind -> tcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (mkTyVar name (kindToTcKind kind)) -kcHsTyVar :: HsTyVar name -> NF_TcM s TcKind +kcHsTyVar :: HsTyVarBndr name -> NF_TcM s TcKind kcHsTyVar (UserTyVar name) = newKindVar kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (kindToTcKind kind) \end{code} @@ -716,10 +693,6 @@ sigPatCtxt bound_tvs bound_ids tidy_env %************************************************************************ \begin{code} -naughtyCCallContextErr clas_name - = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas_name), - ptext SLIT("in a context")] - typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) typeKindCtxt :: RenamedHsType -> Message @@ -742,5 +715,5 @@ tyVarAsClassErr name ambigErr (c, ts) ty = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprConstraint c ts), nest 4 (ptext SLIT("for the type:") <+> ppr ty), - nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>."))] + nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>"))] \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e193c7eada..f5045e409b 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -26,11 +26,8 @@ import TcEnv ( tcLookupValue, tcLookupClassByKey, ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) import TcMonoType ( tcHsSigType ) -import TcUnify ( unifyTauTy, unifyListTy, - unifyTupleTy, unifyUnboxedTupleTy - ) +import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) -import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity @@ -47,6 +44,7 @@ import SrcLoc ( SrcLoc ) import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey, cCallableClassKey ) +import BasicTypes ( isBoxed ) import Bag import Util ( zipEqual ) import Outputable @@ -166,18 +164,15 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail) -tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty +tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty = tcAddErrCtxt (patCtxt pat_in) $ - (if boxed - then unifyTupleTy arity pat_ty - else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys -> - - tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys -> + tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> -- possibly do the "make all tuple-pats irrefutable" test: let - unmangled_result = TuplePat pats' boxed + unmangled_result = TuplePat pats' boxity -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. @@ -185,8 +180,8 @@ tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty -- it was easy to do. possibly_mangled_result - | opt_IrrefutableTuples && boxed = LazyPat unmangled_result - | otherwise = unmangled_result + | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result + | otherwise = unmangled_result in returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail) where diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 262ba38cb4..616d717b7f 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,8 +8,8 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVar(..) ) -import HsCore ( UfRuleBody(..) ) +import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVarBndr(..) ) +import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedHsDecl ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad @@ -35,16 +35,20 @@ tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl]) tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) -> returnTc (plusLIEs lies, rules) -tcRule (IfaceRuleDecl fun (UfRuleBody name vars args rhs) src_loc) +tcRule (IfaceRule name vars fun args rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ tcVar fun `thenTc` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> mapTc tcCoreExpr args `thenTc` \ args' -> tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (emptyLIE, IfaceRuleDecl fun' (CoreRuleBody name vars' args' rhs') src_loc) + returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) -tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) +tcRule (IfaceRuleOut fun rule) + = tcVar fun `thenTc` \ fun' -> + returnTc (emptyLIE, IfaceRuleOut fun' rule) + +tcRule (HsRule name sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy_OpenKind `thenNF_Tc` \ rule_ty -> @@ -96,7 +100,7 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) tcSimplifyAndCheck (text "tcRule") tpl_tvs lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) -> - returnTc (lie', RuleDecl name (varSetElems tpl_tvs) + returnTc (lie', HsRule name (varSetElems tpl_tvs) (map RuleBndr tpl_ids) -- yuk (mkHsLet lhs_binds lhs') (mkHsLet rhs_binds rhs') diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b24673a70e..bdf1488e57 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,19 +11,19 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn ( HsDecl(..), TyClDecl(..), - HsType(..), HsTyVar, + HsType(..), HsTyVarBndr, ConDecl(..), ConDetails(..), BangType(..), - Sig(..), HsPred(..), + Sig(..), HsPred(..), HsTupCon(..), tyClDeclName, isClassDecl, isSynDecl ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name ) import BasicTypes ( RecFlag(..), NewOrData(..), Arity ) import TcMonad import Inst ( InstanceMapper ) import TcClassDcl ( kcClassDecl, tcClassDecl1 ) import TcEnv ( ValueEnv, TcTyThing(..), - tcExtendTypeEnv, getAllEnvTyCons + tcExtendTypeEnv, getEnvAllTyCons ) import TcTyDecls ( tcTyDecl, kcTyDecl ) import TcMonoType ( kcHsTyVar ) @@ -87,9 +87,11 @@ tcGroup unf_env inst_mapper scc -- Tie the knot -- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_` - fixTc ( \ ~(rec_tyclss, rec_vrcs, _) -> + fixTc ( \ ~(rec_tyclss, _) -> let - rec_env = listToUFM rec_tyclss + rec_env = listToUFM rec_tyclss + rec_tycons = getEnvAllTyCons rec_tyclss + rec_vrcs = calcTyConArgVrcs rec_tycons in -- Do type checking @@ -99,13 +101,8 @@ tcGroup unf_env inst_mapper scc `thenTc` \ tyclss -> tcGetEnv `thenTc` \ env -> - let - tycons = getAllEnvTyCons env - vrcs = calcTyConArgVrcs tycons - in - - returnTc (tyclss, vrcs, env) - ) `thenTc` \ (_, _, env) -> + returnTc (tyclss, env) + ) `thenTc` \ (_, env) -> -- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_` returnTc env where @@ -135,11 +132,9 @@ tcDecl :: RecFlag -- True => recursive group tcDecl is_rec_group unf_env inst_mapper vrcs_env decl = tcAddDeclCtxt decl $ if isClassDecl decl then - tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas -> - returnTc (getName clas, AClass clas) + tcClassDecl1 unf_env inst_mapper vrcs_env decl else - tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon -> - returnTc (getName tycon, ATyCon tycon) + tcTyDecl is_rec_group vrcs_env decl tcAddDeclCtxt decl thing_inside @@ -150,9 +145,9 @@ tcAddDeclCtxt decl thing_inside (name, loc, thing) = case decl of (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") - (TySynonym name _ _ loc) -> (name, loc, "type synonym") - (TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type") - (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype") + (TySynonym name _ _ loc) -> (name, loc, "type synonym") + (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "data type") + (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "newtype") ctxt = hsep [ptext SLIT("In the"), text thing, ptext SLIT("declaration for"), quotes (ppr name)] @@ -169,7 +164,7 @@ bound in type, data, newtype and class declarations, Why do we need to grab all these type variables at once, including those locally-quantified type variables in class op signatures? - [Incidentally, this only works because the names are all unique by now.] + [Incidentally, this only works because the names are all unique by now.] Because we can only commit to the final kind of a type variable when we've completed the mutually recursive group. For example: @@ -184,36 +179,35 @@ Here, the kind of the locally-polymorphic type variable "b" depends on *all the uses of class D*. For example, the use of Monad c in bop's type signature means that D must have kind Type->Type. + [April 00: looks as if we've dropped this subtlety; I'm not sure when] \begin{code} -getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, Maybe Arity, TcTyThing)) +getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, TcTyThing)) getTyBinding1 (TySynonym name tyvars _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> newKindVar `thenNF_Tc` \ result_kind -> returnNF_Tc (name, (foldr mkArrowKind result_kind arg_kinds, - Just (length tyvars), - ATyCon (pprPanic "ATyCon: syn" (ppr name)))) + ASynTyCon (pprPanic "ATyCon: syn" (ppr name)) (length tyvars))) -getTyBinding1 (TyData _ _ name tyvars _ _ _ _) +getTyBinding1 (TyData _ _ name tyvars _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, - Nothing, - ATyCon (error "ATyCon: data"))) + ADataTyCon (error "ATyCon: data"))) getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, - Just (length tyvars), - AClass (error "AClass"))) + AClass (pprPanic "AClass" (ppr name)) (length tyvars))) -- Zonk the kind to its final form, and lookup the -- recursive tycon/class -getTyBinding2 rec_env (name, (tc_kind, maybe_arity, thing)) +getTyBinding2 rec_env (name, (tc_kind, thing)) = zonkTcKindToKind tc_kind `thenNF_Tc` \ kind -> - returnNF_Tc (name, (kind, maybe_arity, mk_thing thing (lookupUFM rec_env name))) + returnNF_Tc (name, (kind, mk_thing thing (lookupUFM rec_env name))) where - mk_thing (ATyCon _) ~(Just (ATyCon tc)) = ATyCon tc - mk_thing (AClass _) ~(Just (AClass cls)) = AClass cls + mk_thing (ADataTyCon _) ~(Just (ADataTyCon tc)) = ADataTyCon tc + mk_thing (ASynTyCon _ arity) ~(Just (ASynTyCon tc _)) = ASynTyCon tc arity + mk_thing (AClass _ arity) ~(Just (AClass cls _)) = AClass cls arity \end{code} @@ -272,7 +266,7 @@ mk_cls_edges other_decl ---------------------------------------------------- mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique]) -mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _) +mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs)) @@ -313,30 +307,20 @@ get_bty (Unbanged ty) = get_ty ty get_bty (Unpacked ty) = get_ty ty ---------------------------------------------------- -get_ty (MonoTyVar name) - = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name -get_ty (MonoTyApp ty1 ty2) - = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (MonoFunTy ty1 ty2) - = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (MonoListTy ty) - = set_name listTyCon_name `unionUniqSets` get_ty ty -get_ty (MonoTupleTy tys boxed) - = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys -get_ty (MonoUsgTy _ ty) - = get_ty ty -get_ty (MonoUsgForAllTy _ ty) - = get_ty ty -get_ty (HsForAllTy _ ctxt mty) - = get_ctxt ctxt `unionUniqSets` get_ty mty -get_ty (MonoDictTy name _) - = set_name name -get_ty (MonoIParamTy name _) - = emptyUniqSet +get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet + | otherwise = set_name name +get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) +get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) +get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty +get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys +get_ty (HsUsgTy _ ty) = get_ty ty +get_ty (HsUsgForAllTy _ ty) = get_ty ty +get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty +get_ty (HsPredTy (HsPClass name _)) = set_name name +get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think ---------------------------------------------------- -get_tys tys - = unionManyUniqSets (map get_ty tys) +get_tys tys = unionManyUniqSets (map get_ty tys) ---------------------------------------------------- get_sigs sigs diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 450dad952c..a6f151d3b8 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -25,7 +25,7 @@ import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope, tcContext, tcHsTopTypeKind ) import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints ) -import TcEnv ( tcLookupTy, TcTyThing(..) ) +import TcEnv ( tcLookupTy, tcLookupValueByKey, TcTyThing(..) ) import TcMonad import TcUnify ( unifyKind ) @@ -40,7 +40,7 @@ import Var ( Id, TyVar ) import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) import Outputable import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, - tyConDataCons, tyConTyVars, + tyConDataConsIfAvailable, tyConTyVars, isSynTyCon, isNewTyCon ) import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, @@ -52,6 +52,7 @@ import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, import TysWiredIn ( unitTy ) import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) +import Unique ( unpackCStringIdKey ) import Util ( equivClasses ) import FiniteMap ( FiniteMap, lookupWithDefaultFM ) import CmdLineOpts ( opt_GlasgowExts ) @@ -67,13 +68,13 @@ import CmdLineOpts ( opt_GlasgowExts ) kcTyDecl :: RenamedTyClDecl -> TcM s () kcTyDecl (TySynonym name tyvar_names rhs src_loc) - = tcLookupTy name `thenNF_Tc` \ (kind, _, _) -> + = tcLookupTy name `thenNF_Tc` \ (kind, _) -> tcExtendTopTyVarScope kind tyvar_names $ \ _ result_kind -> tcHsTypeKind rhs `thenTc` \ (rhs_kind, _) -> unifyKind result_kind rhs_kind -kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc) - = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _, _) -> +kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ _ src_loc) + = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _) -> tcExtendTopTyVarScope kind tyvar_names $ \ result_kind _ -> tcContext context `thenTc_` mapTc kcConDecl con_decls `thenTc_` @@ -107,10 +108,10 @@ kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc) %************************************************************************ \begin{code} -tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon +tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing) tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) - = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) -> + = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ASynTyCon _ arity) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) -> -- If the RHS mentions tyvars that aren't in scope, we'll @@ -123,12 +124,12 @@ tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) tycon_name tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs in - returnTc tycon + returnTc (tycon_name, ASynTyCon tycon arity) -tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) +tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls nconstrs derivings pragmas src_loc) = -- Lookup the pieces - tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) -> + tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ADataTyCon rec_tycon) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> -- Typecheck the pieces @@ -148,16 +149,16 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ tycon_name tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs - data_cons + data_cons nconstrs derived_classes flavour is_rec in - returnTc tycon + returnTc (tycon_name, ADataTyCon tycon) where tc_derivs Nothing = returnTc [] tc_derivs (Just ds) = mapTc tc_deriv ds - tc_deriv name = tcLookupTy name `thenTc` \ (_, _, AClass clas) -> + tc_deriv name = tcLookupTy name `thenTc` \ (_, AClass clas _) -> returnTc clas \end{code} @@ -313,7 +314,9 @@ mkImplicitDataBinds_one tycon in returnTc (all_ids, binds) where - data_cons = tyConDataCons tycon + data_cons = tyConDataConsIfAvailable tycon + -- Abstract types mean we don't bring the + -- data cons into scope, which should be fine data_con_wrapper_ids = map dataConWrapId data_cons @@ -336,7 +339,8 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- data type use the same type variables = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - returnTc (mkRecordSelId tycon first_field_label) + tcLookupValueByKey unpackCStringIdKey `thenTc` \ unpack_id -> + returnTc (mkRecordSelId tycon first_field_label unpack_id) where field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 09695e77fe..9d684c1999 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -8,7 +8,7 @@ updatable substitution). \begin{code} module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy, + unifyFunTy, unifyListTy, unifyTupleTy, unifyKind, unifyKinds, unifyTypeKind ) where @@ -25,8 +25,7 @@ import Type ( tyVarsOfType, splitAppTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar ) -import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, - tyConArity ) +import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity ) import Name ( hasBetterProv ) import Var ( TyVar, tyVarKind, varName, isSigTyVar ) import VarEnv @@ -36,8 +35,8 @@ import TcType ( TcType, TcTauType, TcTyVar, TcKind, tcGetTyVar, tcPutTyVar, zonkTcType, tcTypeKind ) -- others: -import BasicTypes ( Arity ) -import TysWiredIn ( listTyCon, mkListTy, mkTupleTy, mkUnboxedTupleTy ) +import BasicTypes ( Arity, Boxity, isBoxed ) +import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) import PprType () -- Instances import Util import Outputable @@ -404,45 +403,29 @@ unify_list_ty_help ty -- Revert to ordinary unification \end{code} \begin{code} -unifyTupleTy :: Arity -> TcType -> TcM s [TcType] -unifyTupleTy arity ty@(TyVarTy tyvar) +unifyTupleTy :: Boxity -> Arity -> TcType -> TcM s [TcType] +unifyTupleTy boxity arity ty@(TyVarTy tyvar) = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of - Just ty' -> unifyTupleTy arity ty' - other -> unify_tuple_ty_help arity ty + Just ty' -> unifyTupleTy boxity arity ty' + other -> unify_tuple_ty_help boxity arity ty -unifyTupleTy arity ty +unifyTupleTy boxity arity ty = case splitTyConApp_maybe ty of - Just (tycon, arg_tys) | isTupleTyCon tycon - && tyConArity tycon == arity - -> returnTc arg_tys - other -> unify_tuple_ty_help arity ty - -unify_tuple_ty_help arity ty - = mapNF_Tc (\ _ -> newTyVarTy boxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys -> - unifyTauTy ty (mkTupleTy arity arg_tys) `thenTc_` - returnTc arg_tys -\end{code} - -\begin{code} -unifyUnboxedTupleTy :: Arity -> TcType -> TcM s [TcType] -unifyUnboxedTupleTy arity ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyUnboxedTupleTy arity ty' - other -> unify_unboxed_tuple_ty_help arity ty - -unifyUnboxedTupleTy arity ty - = case splitTyConApp_maybe ty of - Just (tycon, arg_tys) | isUnboxedTupleTyCon tycon - && tyConArity tycon == arity - -> returnTc arg_tys - other -> unify_tuple_ty_help arity ty - -unify_unboxed_tuple_ty_help arity ty - = mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..arity] `thenNF_Tc` \ arg_tys -> - unifyTauTy ty (mkUnboxedTupleTy arity arg_tys) `thenTc_` + Just (tycon, arg_tys) + | isTupleTyCon tycon + && tyConArity tycon == arity + && tupleTyConBoxity tycon == boxity + -> returnTc arg_tys + other -> unify_tuple_ty_help boxity arity ty + +unify_tuple_ty_help boxity arity ty + = mapNF_Tc new_tyvar [1..arity] `thenNF_Tc` \ arg_tys -> + unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_` returnTc arg_tys + where + new_tyvar _ | isBoxed boxity = newTyVarTy boxedTypeKind + | otherwise = newTyVarTy_OpenKind \end{code} Make sure a kind is of the form (Type b) for some boxity b. diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 035a12c2af..781e342628 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -5,7 +5,7 @@ \begin{code} module Class ( - Class, ClassOpItem, + Class, ClassOpItem, ClassPred, ClassContext, FunDep, mkClass, classTyVars, classKey, className, classSelIds, classTyCon, @@ -40,7 +40,7 @@ data Class className :: Name, classTyVars :: [TyVar], -- The class type variables - classFunDeps :: [([TyVar], [TyVar])], -- The functional dependencies + classFunDeps :: [FunDep TyVar], -- The functional dependencies classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the classSCSels :: [Id], -- corresponding selector functions to @@ -54,6 +54,12 @@ data Class classTyCon :: TyCon -- The data type constructor for dictionaries } -- of this class +type ClassPred = (Class, [Type]) +type ClassContext = [ClassPred] + +type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ... + -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] + type ClassOpItem = (Id, -- Selector function; contains unfolding Id, -- Default methods Bool) -- True <=> an explicit default method was diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index c1db64ebab..686d98d6c4 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -15,20 +15,34 @@ module FunDeps ( #include "HsVersions.h" -import Class ( classTvsFds ) -import Type ( tyVarsOfType ) -import Outputable ( interppSP, ptext, empty, hsep, punctuate, comma ) -import UniqSet ( elementOfUniqSet, addOneToUniqSet, - uniqSetToList, unionManyUniqSets ) +import Var ( TyVar ) +import Class ( Class, FunDep, classTvsFds ) +import Type ( Type, tyVarsOfTypes ) +import Outputable ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma ) +import UniqSet +import VarSet +import Unique ( Uniquable ) import List ( elemIndex ) \end{code} \begin{code} +oclose :: Uniquable a => [FunDep a] -> UniqSet a -> UniqSet a +-- (oclose fds tvs) closes the set of type variables tvs, +-- wrt the functional dependencies fds. The result is a superset +-- of the argument set. +-- +-- For example, +-- oclose [a -> b] {a} = {a,b} +-- oclose [a b -> c] {a} = {a} +-- oclose [a b -> c] {a,b} = {a,b,c} +-- If all of the things on the left of an arrow are in the set, add +-- the things on the right of that arrow. + oclose fds vs = case oclose1 fds vs of (vs', False) -> vs' - (vs', True) -> oclose fds vs' + (vs', True) -> oclose fds vs' oclose1 [] vs = (vs, False) oclose1 (fd@(ls, rs):fds) vs = @@ -44,30 +58,32 @@ osubset [] vs = True osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False ounion [] ys = (ys, False) -ounion (x:xs) ys = - if x `elementOfUniqSet` ys then (ys', b) else (addOneToUniqSet ys' x, True) +ounion (x:xs) ys + | x `elementOfUniqSet` ys = (ys', b) + | otherwise = (addOneToUniqSet ys' x, True) where (ys', b) = ounion xs ys -instantiateFdClassTys clas ts = - map (lookupInstFundep tyvars ts) fundeps - where - (tyvars, fundeps) = classTvsFds clas - lookupInstFundep tyvars ts (us, vs) = - (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs) +instantiateFdClassTys :: Class -> [a] -> [([a], [a])] +-- Get the FDs of the class, and instantiate them +instantiateFdClassTys clas ts + = map (lookupInstFundep tyvars ts) fundeps + where + (tyvars, fundeps) = classTvsFds clas + lookupInstFundep tyvars ts (us, vs) + = (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs) + lookupInstTys tyvars ts = map (lookupInstTy tyvars ts) lookupInstTy tyvars ts u = ts !! i where Just i = elemIndex u tyvars -tyVarFunDep fdtys = - map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys - where - getTyVars ty = tyVarsOfType ty - unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs)) +tyVarFunDep :: [FunDep Type] -> [FunDep TyVar] +tyVarFunDep fdtys + = [(varSetElems (tyVarsOfTypes xs), varSetElems (tyVarsOfTypes xs)) | (xs,ys) <- fdtys] +pprFundeps :: Outputable a => [FunDep a] -> SDoc pprFundeps [] = empty pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds)) ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs] - \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 8d0d675569..6b22faa886 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -116,7 +116,7 @@ ppr_ty env ctxt_prec (TyVarTy tyvar) ppr_ty env ctxt_prec ty@(TyConApp tycon tys) -- KIND CASE; it's of the form (Type x) - | tycon_uniq == typeConKey && n_tys == 1 + | tycon `hasKey` typeConKey && n_tys == 1 = -- For kinds, print (Type x) as just x if x is a -- type constructor (must be Boxed, Unboxed, AnyBox) -- Otherwise print as (Type x) @@ -136,7 +136,7 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) = parens (char '#' <+> tys_w_commas <+> char '#') -- LIST CASE - | tycon_uniq == listTyConKey && n_tys == 1 + | tycon `hasKey` listTyConKey && n_tys == 1 = brackets (ppr_ty env tOP_PREC ty1) -- DICTIONARY CASE, prints {C a} @@ -154,7 +154,6 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) where - tycon_uniq = tyConUnique tycon n_tys = length tys (ty1:_) = tys Just pred = maybe_pred @@ -167,18 +166,11 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) ppr_ty env ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> maybeParen ctxt_prec fUN_PREC $ - if ifaceStyle sty then - sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"), - ppr_ty env tOP_PREC rho - ] - else - -- The type checker occasionally prints a type in an error message, - -- and it had better come out looking like a user type - sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), - ppr_theta theta, - ppr_ty env tOP_PREC tau - ] - where + sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), + ppr_theta theta, + ppr_ty env tOP_PREC tau + ] + where (tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04) (theta, tau) = splitRhoTy rho @@ -267,7 +259,7 @@ and when in debug mode. \begin{code} pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then + if (ifaceStyle sty && kind /= boxedTypeKind) || debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 1ca3393d4d..48445e4e9c 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -9,7 +9,8 @@ module TyCon( isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, + isEnumerationTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, mkAlgTyCon, @@ -27,7 +28,7 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, + tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, tyConDerivings, tyConTheta, @@ -49,9 +50,9 @@ import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) -import Class ( Class ) +import Class ( Class, ClassContext ) import Var ( TyVar ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) +import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) import Maybes import Name ( Name, nameUnique, NamedThing(getName) ) import Unique ( Unique, Uniquable(..), anyBoxConKey ) @@ -87,7 +88,7 @@ data TyCon tyConTyVars :: [TyVar], tyConArgVrcs :: ArgVrcs, - algTyConTheta :: [(Class,[Type])], + algTyConTheta :: ClassContext, dataCons :: [DataCon], -- Its data constructors, with fully polymorphic types @@ -97,6 +98,13 @@ data TyCon -- (b) in a quest for fast compilation we don't import -- the constructors + noOfDataCons :: Int, -- Number of data constructors + -- Usually this is the same as the length of the + -- dataCons field, but the latter may be empty if + -- we imported the type abstractly. But even if we import + -- abstractly we still need to know the number of constructors + -- so we can get the return convention right. Tiresome! + algTyConDerivings :: [Class], -- Classes which have derived instances algTyConFlavour :: AlgTyConFlavour, @@ -125,7 +133,7 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConBoxed :: Bool, -- True for boxed; False for unboxed + tyConBoxed :: Boxity, tyConTyVars :: [TyVar], dataCon :: DataCon } @@ -213,7 +221,7 @@ mkFunTyCon name kind tyConArity = 2 } -mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -223,6 +231,7 @@ mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec tyConArgVrcs = argvrcs, algTyConTheta = theta, dataCons = cons, + noOfDataCons = ncons, algTyConDerivings = derivs, algTyConClass_maybe = Nothing, algTyConFlavour = flavour, @@ -239,6 +248,7 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour tyConArgVrcs = argvrcs, algTyConTheta = [], dataCons = [con], + noOfDataCons = 1, algTyConDerivings = [], algTyConClass_maybe = Just clas, algTyConFlavour = flavour, @@ -289,13 +299,13 @@ isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False isUnLiftedTyCon (PrimTyCon {}) = True -isUnLiftedTyCon (TupleTyCon { tyConBoxed = False }) = True +isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity) isUnLiftedTyCon _ = False -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon isBoxedTyCon (AlgTyCon {}) = True isBoxedTyCon (FunTyCon {}) = True -isBoxedTyCon (TupleTyCon {tyConBoxed = boxed}) = boxed +isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep -- isAlgTyCon returns True for both @data@ and @newtype@ @@ -307,7 +317,7 @@ isAlgTyCon other = False isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of NewTyCon _ -> False other -> True -isDataTyCon (TupleTyCon {tyConBoxed = True}) = True +isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True @@ -333,29 +343,40 @@ isSynTyCon _ = False isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True isEnumerationTyCon other = False --- The unit tycon isn't classed as a tuple tycon -isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2 -isTupleTyCon other = False +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon (TupleTyCon {}) = True +isTupleTyCon other = False -isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True +isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnboxedTupleTyCon other = False +isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity +isBoxedTupleTyCon other = False + +tupleTyConBoxity tc = tyConBoxed tc + isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True isRecursiveTyCon other = False \end{code} \begin{code} tyConDataCons :: TyCon -> [DataCon] -tyConDataCons (AlgTyCon {dataCons = cons}) = cons -tyConDataCons (TupleTyCon {dataCon = con}) = [con] -tyConDataCons other = [] +tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons + where + cons = tyConDataConsIfAvailable tycon + +tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons -- Empty for abstract types +tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con] +tyConDataConsIfAvailable other = [] -- You may think this last equation should fail, -- but it's quite convenient to return no constructors for -- a synonym; see for example the call in TcTyClsDecls. tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {dataCons = cons}) = length cons -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -372,7 +393,7 @@ tyConDerivings other = [] \end{code} \begin{code} -tyConTheta :: TyCon -> [(Class, [Type])] +tyConTheta :: TyCon -> ClassContext tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -- should ask about anything else \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index b54183e97c..877b115203 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -93,7 +93,7 @@ import VarSet import Name ( Name, NamedThing(..), mkLocalName, tidyOccName ) import NameSet -import Class ( classTyCon, Class ) +import Class ( classTyCon, Class, ClassPred, ClassContext ) import TyCon ( TyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, @@ -316,7 +316,7 @@ splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for -- *saturated* applications of *algebraic* data types -- "Algebraic" => newtype, data type, or dictionary (not function types) --- We return the constructors too. +-- We return the constructors too, so there had better be some. splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) splitAlgTyConApp_maybe (TyConApp tc tys) @@ -332,6 +332,9 @@ splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) (tc, tys, tyConDataCons tc) splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty +#ifdef DEBUG +splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty) +#endif \end{code} "Dictionary" types are just ordinary data types, but you can @@ -687,14 +690,14 @@ ClassPred and ClassContext are used in class and instance declarations. %************************************************************************ \begin{code} -type RhoType = Type -type TauType = Type data PredType = Class Class [Type] | IParam Name Type -type ThetaType = [PredType] -type ClassPred = (Class, [Type]) -type ClassContext = [ClassPred] -type SigmaType = Type + deriving( Eq, Ord ) + +type ThetaType = [PredType] +type RhoType = Type +type TauType = Type +type SigmaType = Type \end{code} \begin{code} diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index b5e04a1299..b71576bf06 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -38,7 +38,7 @@ import TyCon ( TyCon, KindCon, -- others import SrcLoc ( mkBuiltinSrcLoc ) -import PrelMods ( pREL_GHC ) +import PrelNames ( pREL_GHC ) import Unique -- quite a few *Keys import Util ( thenCmp ) \end{code} diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index dfab7a80f1..b3fe0a5f1a 100644 --- a/ghc/compiler/types/Variance.lhs +++ b/ghc/compiler/types/Variance.lhs @@ -12,7 +12,7 @@ module Variance( #include "HsVersions.h" import TypeRep ( Type(..), TyNote(..) ) -- friend -import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars, +import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars, tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) import DataCon ( dataConRepArgTys ) @@ -45,7 +45,7 @@ calcTyConArgVrcs :: [TyCon] calcTyConArgVrcs tycons = let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons - initial tc = if isAlgTyCon tc && null (tyConDataCons tc) then + initial tc = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then -- make pessimistic assumption (and warn) take (tyConArity tc) abstractVrcs else @@ -75,15 +75,20 @@ calcTyConArgVrcs tycons -> ArgVrcs -- new ArgVrcs for tycon tcaoIter oi tc | isAlgTyCon tc - = let cs = tyConDataCons tc - vs = tyConTyVars tc - argtys = concatMap dataConRepArgTys cs - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) + = if null data_cons then + -- Abstract types get uninformative variances + abstractVrcs + else + map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) vs + where + data_cons = tyConDataConsIfAvailable tc + vs = tyConTyVars tc + argtys = concatMap dataConRepArgTys data_cons + myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ + tyConArgVrcs_maybe tc) + tc + -- we use the already-computed result for tycons not in this SCC tcaoIter oi tc | isSynTyCon tc = let (tyvs,ty) = getSynTyConDefn tc diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index d0f062e003..b0f5f56b52 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -18,6 +18,7 @@ import UsageSPLint import UConSet import CoreSyn +import CoreFVs ( mustHaveLocalBinding ) import Rules ( RuleBase ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( UsageAnn(..), @@ -31,7 +32,7 @@ import TyCon ( tyConArgVrcs_maybe, isFunTyCon ) import Literal ( Literal(..), literalType ) import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo ) import IdInfo ( setLBVarInfo, LBVarInfo(..) ) -import Id ( mayHaveNoBinding, isExportedId ) +import Id ( isExportedId ) import Name ( isLocallyDefined ) import VarEnv import VarSet @@ -398,7 +399,7 @@ lookupVar :: VarEnv Var -> Var -> Var --lookupVar ve v = error "lookupVar unimplemented" lookupVar ve v = case lookupVarEnv ve v of Just v' -> v' - Nothing -> ASSERT( not (isLocallyDefined v) || (mayHaveNoBinding v) ) + Nothing -> ASSERT( not (mustHaveLocalBinding v) ) ASSERT( isUsgTy (varType v) ) v diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 1628413e31..4fb51f0eeb 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -25,9 +25,10 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, #include "HsVersions.h" import CoreSyn +import CoreFVs ( mustHaveLocalBinding ) import Literal ( Literal(..) ) import Var ( Var, varName, varType, setVarType, mkUVar ) -import Id ( mayHaveNoBinding, isExportedId ) +import Id ( isExportedId ) import Name ( isLocallyDefined ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( UsageAnn(..), isUsgTy, splitFunTys ) @@ -182,8 +183,7 @@ assumed true (exactly) of all imported ids. \begin{code} hasLocalDef :: Var -> Bool -hasLocalDef var = isLocallyDefined var - && not (mayHaveNoBinding var) +hasLocalDef var = mustHaveLocalBinding var hasUsgInfo :: Var -> Bool hasUsgInfo var = (not . isLocallyDefined) var diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 7ac34b2637..0dfc585c2d 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -153,7 +153,7 @@ graphFromEdges edges edges1 = zipWith (,) [0..] sorted_edges graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1] - key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] + key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] vertex_map = array bounds edges1 (_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False } diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 19ad666677..46cb73462c 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -179,7 +179,7 @@ printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) -- printForIface prints all on one line for interface files. -- It's called repeatedly for successive lines printForIface :: Handle -> SDoc -> IO () -printForIface handle doc = printDoc OneLineMode handle (doc PprInterface) +printForIface handle doc = printDoc LeftMode handle (doc PprInterface) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 1a3f70759c..6e2444860e 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -792,23 +792,12 @@ fillNB g p k ys = fill1 g p k ys ********************************************************* \begin{code} -best :: Mode - -> Int -- Line length +best :: Int -- Line length -> Int -- Ribbon length -> RDoc -> RDoc -- No unions in here! -best OneLineMode IBOX(w) IBOX(r) p - = get p - where - get Empty = Empty - get NoDoc = NoDoc - get (NilAbove p) = nilAbove_ (get p) - get (TextBeside s sl p) = textBeside_ s sl (get p) - get (Nest k p) = get p -- Elide nest - get (p `Union` q) = first (get p) (get q) - -best mode IBOX(w) IBOX(r) p +best IBOX(w) IBOX(r) p = get w p where get :: INT -- (Remaining) width of line @@ -858,7 +847,7 @@ minn x y | x LT y = x first p q | nonEmptySet p = p | otherwise = q -nonEmptySet NoDoc = False +nonEmptySet NoDoc = False nonEmptySet (p `Union` q) = True nonEmptySet Empty = True nonEmptySet (NilAbove p) = True -- NoDoc always in first line @@ -903,13 +892,30 @@ string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2 \begin{code} -fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc) +fullRender OneLineMode _ _ txt end doc + = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union p q) = (lay q) -- Second arg can't be NoDoc + lay (Nest k p) = lay p + lay Empty = end + lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line + lay (TextBeside s sl p) = s `txt` lay p + +fullRender LeftMode _ _ txt end doc + = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union p q) = lay (first p q) + lay (Nest k p) = lay p + lay Empty = end + lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line + lay (TextBeside s sl p) = s `txt` lay p fullRender mode line_length ribbons_per_line txt end doc = display mode line_length ribbon_length txt end best_doc where - best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc) + best_doc = best hacked_line_length ribbon_length (reduceDoc doc) hacked_line_length, ribbon_length :: Int ribbon_length = round (fromInt line_length / ribbons_per_line) @@ -951,15 +957,6 @@ display mode IBOX(page_width) IBOX(ribbon_width) txt end doc }} cant_fail = error "easy_display: NoDoc" -easy_display nl_text txt end doc - = lay doc cant_fail - where - lay NoDoc no_doc = no_doc - lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc - lay (Nest k p) no_doc = lay p no_doc - lay Empty no_doc = end - lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line - lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8)) | otherwise = spaces n diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 8e2198b050..2bb567db0a 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -28,7 +28,7 @@ module Util ( assoc, assocUsing, assocDefault, assocDefaultUsing, -- duplicate handling - hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq, + hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq, -- sorting IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) @@ -364,6 +364,17 @@ removeDups cmp xs where collect_dups dups_so_far [x] = (dups_so_far, x) collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) + +removeDupsEq :: Eq a => [a] -> ([a], [[a]]) +-- Same, but with only equality +-- It's worst case quadratic, but we only use it on short lists +removeDupsEq [] = ([], []) +removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs) + where + (ys,zs) = removeDupsEq (filter (/= x) xs) +removeDupsEq (x:xs) | otherwise = (x:ys, zs) + where + (ys,zs) = removeDupsEq xs \end{code} diff --git a/ghc/docs/users_guide/debugging.sgml b/ghc/docs/users_guide/debugging.sgml index 943315e4db..f711a382b8 100644 --- a/ghc/docs/users_guide/debugging.sgml +++ b/ghc/docs/users_guide/debugging.sgml @@ -204,6 +204,7 @@ renamer output </Para> </ListItem> </VarListEntry> + <VarListEntry> <Term><Option>-ddump-tc</Option>:</Term> <ListItem> @@ -212,6 +213,20 @@ typechecker output </Para> </ListItem> </VarListEntry> + +<VarListEntry> +<Term><Option>-ddump-types</Option>:</Term> +<ListItem> +<Para> +Dump a type signature for each value defined at the top level +of the module. The list is sorted alphabetically. +Using <Option>-dppr-debug</Option> dumps a type signature for +all the imported and system-defined things as well; useful +for debugging the compiler. +</Para> +</ListItem> +</VarListEntry> + <VarListEntry> <Term><Option>-ddump-deriv</Option>:</Term> <ListItem> diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl deleted file mode 100644 index 32417017fb..0000000000 --- a/ghc/driver/ghc-iface.lprl +++ /dev/null @@ -1,377 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-iface-thing]{Interface-file handling} -%* * -%************************************************************************ - -\begin{code} -%OldVersion = (); -%Decl = (); # details about individual definitions -%Stuff = (); # where we glom things together -%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't -%HiHasBeenRead = ('old', 0, 'new', 0); -%ModuleVersion = ('old', 0, 'new', 0); - -%HiSections = (); - -sub postprocessHiFile { - local($hsc_hi, # The iface info produced by hsc. - $hifile_target, # The name both of the .hi file we - # already have and which we *might* - # replace. - $going_interactive) = @_; - - local($new_hi) = "$Tmp_prefix.hi-new"; - local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target; - - print STDERR "*** New hi file follows...\n" if $Verbose; - system("$Cat $hsc_hi 1>&2") if $Verbose; - - &constructNewHiFile($hsc_hi, *hifile_target, $new_hi, $show_hi_diffs); - - # run diff if they asked for it - if ($show_hi_diffs) { - if ( $HiDiff_flag eq 'usages' ) { - # lots of near-useless info; but if you want it... - &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0", - "Diff'ing old and new .$HiSuffix files"); # NB: to stderr - } else { - # strip out usages, *then* run diff - local($hi_before) = "$Tmp_prefix.hi-before"; - local($hi_after) = "$Tmp_prefix.hi-now"; - - &deUsagifyHi($hifile_target, $hi_before); - &deUsagifyHi($new_hi, $hi_after); - - &run_something("$Cmp -s $hi_before $hi_after || $Diff $hi_before $hi_after 1>&2 || exit 0", - "Diff'ing old and new .$HiSuffix files"); # NB: to stderr - } - } - - # if we produced an interface file "no matter what", - # print what we got on stderr. - if ( $HiOnStdout ) { - if ( $HiWith ne '' ) { - # output some of the sections - local($hi_after) = "$Tmp_prefix.hi-now"; - - foreach $hi ( split(' ',$HiWith) ) { - $HiSection{$hi} = 1; - } - &hiSectionsOnly($new_hi, $hi_after); - - system("$Cat $hi_after 1>&2 ; $Rm $hi_after; "); - } else { - system("$Cat $new_hi 1>&2"); - } - } else { - &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )", - "Replace .$HiSuffix file, if changed"); - } -} - -sub deUsagifyHi { - local($ifile,$ofile) = @_; - - open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n"); - open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n"); - - # read up to _usages_ line - $_ = <OLDHIF>; - while ($_ ne '') { - print NEWHIF $_ unless /^(__interface|import)/; - $_ = <OLDHIF>; - } - - close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n"); - close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n"); -} -\end{code} - -\begin{code} -sub hiSectionsOnly { - local($ifile,$ofile) = @_; - - open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n"); - open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n"); - - # read up to _usages_ line - $_ = <OLDHIF>; - while ($_ ne '' ) { - if ( /^__export/ && $HiSection {'exports'} || - /^import / && $HiSection {'imports'} || - /^\d+ ([^ ]+ :: |type |data |class |newtype )/ && $HiSection {'declarations'} || - /^instance / && $HiSection {'instances'} ) { - print NEWHIF $_; - $_ = <OLDHIF>; - } else { - $_ = <OLDHIF>; - } - } - - close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n"); - close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n"); -} -\end{code} - -\begin{code} -sub constructNewHiFile { - local($hsc_hi, # The iface info produced by hsc. - *hifile_target, # Pre-existing .hi filename (if it exists) - $new_hi, # Filename for new one - $show_hi_diffs) = @_; - local($hiname,$hidir); - local($mod_name_dec); - - &readHiFile('new',$hsc_hi) unless $HiHasBeenRead{'new'} == 1; - - # Sigh, we need decode the module name found in the interface file - # since that's the (base)name we want to use when outputting the - # interface file. - $mod_name_dec = $ModuleName{'new'}; - $mod_name_dec =~ s/zz/z/g; - $mod_name_dec =~ s/ZZ/Z/g; - $mod_name_dec =~ s/zu/_/g; - - if ($Specific_hi_file eq '') { # -ohi is used even if module name != stem of filename. - ($hiname = $hifile_target) = $1 if $hifile_target =~ /\/?([^\/]+)\.$HiSuffix$/; - if ( $mod_name_dec ne $hiname ) { - $hidir = ''; - # strip off basename only if we've got a dirname. - ($hidir = $hifile_target) =~ s/(.*\/)[^\/]*$/$1/ - if ( $hifile_target =~ /\/$hiname\.$HiSuffix/ ); - $hifile_target = $hidir . $mod_name_dec . ".$HiSuffix"; - } - } - &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1; - - open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n"); - - local(@decl_names) = (); # Declarations in new module - foreach $v (sort (keys %Decl)) { - next unless $v =~ /^new:(.*$)/; - push(@decl_names,$1); - } - - local($new_module_version) = &calcNewModuleVersion(@decl_names); - print NEWHI "__interface ", $PackageName{'new'}, $ModuleName{'new'}, " $new_module_version $Orphan{'new'} $ProjectVersionInt where\n"; - print NEWHI $Stuff{'new:exports'}; - print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq ''; - print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq ''; - - foreach $v (@decl_names) { - &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs); # Print new version number - print NEWHI $Decl{"new:$v"}; # Print the new decl itself - } - print NEWHI $Stuff{'new:rules'} unless $Stuff{'new:rules'} eq ''; - print NEWHI $Stuff{'new:deprecations'} unless $Stuff{'new:deprecations'} eq ''; - - close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n"); -} -\end{code} - -Read the .hi file made by the compiler, or the old one. -All the declarations in the file are stored in - - $Decl{"$mod:$v"} - -where $mod is "new" or "old", depending on whether it's the new or old - .hi file that's being read. - -and $v is - for values v "v" - for tycons T "type T" or "data T" - for classes C "class C" - - -\begin{code} -sub readHiFile { - local($mod, # module to read; can be special tag 'old' - # (old .hi file for module being compiled) or - # 'new' (new proto-.hi file for...) - $hifile) = @_; # actual file to read - - # info about the old version of this module's interface - $HiExists{$mod} = -1; # 1 <=> definitely exists; 0 <=> doesn't - $HiHasBeenRead{$mod} = 0; - $ModuleVersion{$mod} = 0; - $Stuff{"$mod:usages"} = ''; # stuff glommed together - $Stuff{"$mod:exports"} = ''; - $Stuff{"$mod:instances"} = ''; - $Stuff{"$mod:declarations"} = ''; - $Stuff{"$mod:rules"} = ''; - $Stuff{"$mod:deprecations"} = ''; - - if (! -f $hifile) { # no pre-existing .hi file - $HiExists{$mod} = 0; - return(); - } - - open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n"); - $HiExists{$mod} = 1; - hi_line: while (<HIFILE>) { - next if /^ *$/; # blank line - - if ( /^__interface ("[A-Za-z]*"\s*)([A-Z]\S*)\s+(\d+)?\s*(\!)?/ ) { - if ( $mod ne 'new' ) { - # Reading old .hi file - $ModuleVersion{$mod} = $3; - } - - $PackageName{$mod} = $1; - $ModuleName{$mod} = $2; # used to decide name of iface file. - $Orphan{$mod} = $4; - # optional "!" indicates that the - # module contains orphan rules or instance decls - - } elsif ( /^import / ) { - $Stuff{"$mod:usages"} .= $_; # save the whole thing - - } elsif ( /^__export/ ) { - $Stuff{"$mod:exports"} .= $_; - - } elsif ( /^instance / ) { - $Stuff{"$mod:instances"} .= $_; - - } elsif ( /^{-## __R / ) { - $Stuff{"$mod:rules"} .= $_; - - } elsif ( /^{-## __D / ) { - $Stuff{"$mod:deprecations"} .= $_; - - } elsif ( /^-[-]+ .*/ ) { # silently ignore comment lines. - ; - } else { # We're in a declaration - - # Strip off the initial version number, if any - if ( /^([0-9]+)\s+(.*\n)/ ) { - - # The "\n" is because we need to keep the newline at - # the end, so that it looks the same as if there's no version - # number and this if statement doesn't fire. - - # So there's an initial version number - $version = $1; - $_ = $2; - } - - if ( /^type\s+(\S+)/ ) { - # Type declaration - $current_name = "type $1"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^(newtype|data)\s+({.*}\s+=>\s+)?(\S+)\s+/ ) { - # Data declaration - # The (...)? parts skips over the context of a data decl - # to find the name of the type constructor. The curly - # brackets are part of the iface file syntax for contexts - $current_name = "data $3"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) { - # Class declaration - # must be wary of => bit matching after "where"... - # ..hence the [^{}] part - # NB: a class decl may not have a where part at all - $current_name = "class $2"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^infix(r|l)?\s+[0-9]\s+(\S+)/ ) { - # fixity declaration - $current_name = "fixity $2"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^(\S+)\s+::\s+/ ) { - # Value declaration - $current_name = $1; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } else { # Continuation line - # print STDERR "$Pgm:junk old iface line?:$_"; - $Decl{"$mod:$current_name"} .= $_ - } - - } - } - - close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n"); - $HiHasBeenRead{$mod} = 1; -} -\end{code} - -\begin{code} -sub calcNewModuleVersion { - local (@decl_names) = @_; - - return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0; - # could use "time()" as initial version; if a module existed, then was deleted, - # then comes back, we don't want the resurrected one to have an - # lower version number than the original (in case there are any - # lingering references to the original in other .hi files). - - local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two - local($changed_version) = $unchanged_version + 1; - - if ($Orphan{'old'} ne $Orphan{'new'}) { - return(&mv_change($changed_version, "orphan-hood changed")); - } - - foreach $t ( 'usages' , 'exports', 'instances', 'fixities', 'rules', 'deprecations' ) { - return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"}; - } - -# Decl need separate treatment; they aren't in $Stuff - foreach $v (@decl_names) { - return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"}; - } - - print STDERR "$Pgm: module version unchanged at $unchanged_version\n" - if $Verbose; - return($unchanged_version); -} - -sub mv_change { - local($mv, $str) = @_; - - print STDERR "$Pgm: module version changed to $mv; reason: $str\n" - if $Verbose; - return($mv); -} - -sub printNewItemVersion { - local($hifile, $item, $mod_version, $show_hi_diffs) = @_; - local($idecl) = $Decl{"new:$item"}; - - - if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist - if ($show_hi_diffs) {print STDERR "new: $item\n";} - print $hifile "$mod_version "; # Use module version - - } elsif (! defined($OldVersion{"$item"}) ) { - if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";} - print $hifile "$mod_version "; # Use module version - - } elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl - local($odecl) = $Decl{"old:$item"}; - if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl", "New: $idecl";} - print $hifile "--old: ", $OldVersion{"$item"}, " $odecl" - if $Keep_HiDiffs; # show old in interface file - print $hifile "$mod_version "; # Use module version - - } else { # Identical decls, so use old version number - #if ($show_hi_diffs) {print STDERR "$item: unchanged\n";} - print $hifile $OldVersion{"$item"}, " "; - } - return; -} -\end{code} - -\begin{code} -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 7a59b7557c..bda22fca96 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -741,7 +741,7 @@ sub setupOptimiseFlags { # Specialisation is best done before full laziness # so that overloaded functions have all their dictionary lambdas manifest ($Oopt_DoSpecialise) ? ( $Oopt_DoSpecialise, ) : (), - '-ffloat-outwards', +# '-ffloat-outwards', '-ffloat-inwards', '-fsimplify', @@ -1502,7 +1502,7 @@ Now the Haskell compiler, C compiler, and assembler } if (-f $hsc_out_h_stub) { - &run_something("cp $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file'); + &run_something("mv $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file'); } if (-f $hsc_out_c_stub) { @@ -1684,7 +1684,7 @@ sub runHscAndProcessInterfaces { # See if it bailed out early, saying nothing needed doing. # We work this out by seeing if it created an output .hi file - if ( ! -f $hsc_hi && $ProduceHi !~ /-nohifile=/ ) { + if ( ! -f $hsc_out ) { # Doesn't exist, so we bailed out early. # Tell the C compiler and assembler not to run $do_cc = 0; $do_as = 0; @@ -1721,10 +1721,14 @@ sub runHscAndProcessInterfaces { # Interface-handling is important enough to live off by itself - if ( $ProduceHi !~ /-nohifile=/ ) { # If we've produced one, process it. - require('ghc-iface.prl') || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n"); - &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive); + if ( -f $hsc_hi ) { + # print STDERR "Aha! A new hi file\n" ; + &run_something( "mv $hsc_hi $hifile_target", "Copy hi file" ) ; + } else { + # print STDERR "Oh ho! Hi file unchanged\n" ; } + + # if we're going to split up object files, # we inject split markers into the .hc file now if ( $HscLang eq 'C' && $SplitObjFiles ) { diff --git a/ghc/lib/std/Main.hi-boot b/ghc/lib/std/Main.hi-boot index d93b977f4f..844073fda0 100644 --- a/ghc/lib/std/Main.hi-boot +++ b/ghc/lib/std/Main.hi-boot @@ -8,6 +8,6 @@ __interface Main 1 where __export Main main ; -1 main :: __forall [a] => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04. +1 main :: __forall a => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04. diff --git a/ghc/lib/std/PrelErr.hi-boot b/ghc/lib/std/PrelErr.hi-boot index bd7f8f9f01..98d97219e9 100644 --- a/ghc/lib/std/PrelErr.hi-boot +++ b/ghc/lib/std/PrelErr.hi-boot @@ -7,6 +7,6 @@ -- because it's wired into the compiler --------------------------------------------------------------------------- -__interface PrelErr 2 0 where +__interface PrelErr 1 where __export PrelErr error parError; diff --git a/ghc/lib/std/PrelException.hi-boot b/ghc/lib/std/PrelException.hi-boot index 511010d4bf..9be1ea3779 100644 --- a/ghc/lib/std/PrelException.hi-boot +++ b/ghc/lib/std/PrelException.hi-boot @@ -5,8 +5,8 @@ -- for PrelException.hi. --------------------------------------------------------------------------- -__interface PrelException 1 0 where +__interface PrelException 1 where __export PrelException ioError catch; -1 ioError :: __forall [a] => PrelIOBase.IOError -> PrelIOBase.IO a ; -1 catch :: __forall [a] => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04. +1 ioError :: __forall a => PrelIOBase.IOError -> PrelIOBase.IO a ; +1 catch :: __forall a => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04. diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index bc7dac3927..dedb4de5ce 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -5,7 +5,7 @@ -- primitive operations and types that GHC knows about. --------------------------------------------------------------------------- -__interface "std" PrelGHC 2 0 where +__interface "std" PrelGHC 1 407 where __export PrelGHC @@ -341,6 +341,18 @@ __export PrelGHC unsafeCoercezh ; +-- Export PrelErr.error, so that others don't have to import PrelErr +__export PrelErr error ; + +-------------------------------------------------- +-- These imports tell modules low down in the hierarchy that +-- PrelErr and PrelBase are in the same package and +-- should be read from their hi-boot files +import PrelErr @ ; +import PrelNum @ ; + + +-------------------------------------------------- instance {CCallable Charzh} = zdfCCallableCharzh; instance {CCallable Doublezh} = zdfCCallableDoublezh; instance {CCallable Floatzh} = zdfCCallableFloatzh; @@ -350,15 +362,15 @@ instance {CCallable Int64zh} = zdfCCallableInt64zh; instance {CCallable Word64zh} = zdfCCallableWord64zh; instance {CCallable Wordzh} = zdfCCallableWordzh; instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh; -instance __forall [s] => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; +instance __forall s => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh; -instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; +instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; -- CCallable and CReturnable have kind (Type AnyBox) so that -- things like Int# can be instances of CCallable. 1 class CCallable a :: ? ; 1 class CReturnable a :: ? ; -1 assert :: __forall [a] => PrelBase.Bool -> a -> a ; +1 assert :: __forall a => PrelBase.Bool -> a -> a ; -- These guys don't really exist: -- @@ -371,6 +383,6 @@ instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; 1 zdfCCallableWord64zh :: {CCallable Word64zh} ; 1 zdfCCallableWordzh :: {CCallable Wordzh} ; 1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ; -1 zdfCCallableMutableByteArrayzh :: __forall [s] => {CCallable (MutableByteArrayzh s)} ; +1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ; 1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ; -1 zdfCCallableStablePtrzh :: __forall [a] => {CCallable (StablePtrzh a)} ; +1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ; diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index 1ea90d6d13..dcc0c81b3c 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -21,7 +21,6 @@ module PrelList ( any, all, elem, notElem, lookup, maximum, minimum, concatMap, zip, zip3, zipWith, zipWith3, unzip, unzip3, - #ifdef USE_REPORT_PRELUDE #else @@ -483,6 +482,16 @@ foldr2_right k _z y r (x:xs) = k x y (r xs) #-} \end{code} +The foldr2/right rule isn't exactly right, because it changes +the strictness of foldr2 (and thereby zip) + +E.g. main = print (null (zip nonobviousNil (build undefined))) + where nonobviousNil = f 3 + f n = if n == 0 then [] else f (n-1) + +I'm going to leave it though. + + zip takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded. zip3 takes three lists and returns a list of triples. Zips for larger diff --git a/ghc/lib/std/PrelPack.hi-boot b/ghc/lib/std/PrelPack.hi-boot index 37908c8537..e7e6f6e550 100644 --- a/ghc/lib/std/PrelPack.hi-boot +++ b/ghc/lib/std/PrelPack.hi-boot @@ -7,7 +7,7 @@ -- other Prelude files that precede PrelPack --------------------------------------------------------------------------- -__interface PrelPack 1 where +__interface PrelPack 1 1 1 where __export PrelPack packCStringzh ; 1 packCStringzh :: [PrelBase.Char] -> PrelGHC.ByteArrayzh ; diff --git a/ghc/lib/std/PrelShow.lhs b/ghc/lib/std/PrelShow.lhs index 44e336482d..a2147ae40f 100644 --- a/ghc/lib/std/PrelShow.lhs +++ b/ghc/lib/std/PrelShow.lhs @@ -31,6 +31,7 @@ module PrelShow import {-# SOURCE #-} PrelErr ( error ) import PrelBase +import PrelTup import PrelMaybe import PrelList ( (!!), break, dropWhile #ifdef USE_REPORT_PRELUDE diff --git a/ghc/mk/version.mk b/ghc/mk/version.mk index cfda63ae77..7effb2dcb0 100644 --- a/ghc/mk/version.mk +++ b/ghc/mk/version.mk @@ -27,6 +27,12 @@ # ProjectVersionInt does *not* contain the patchlevel (rationale: this # figure is used for conditional compilations, and library interfaces # etc. are not supposed to change between patchlevels). +# +# The ProjectVersionInt is included in interface files, and GHC +# checks that it's reading interface generated by the same ProjectVersion +# as itself. It does this even though interface file syntax may not +# change between versions. Rationale: calling conventions or other +# random .o-file stuff might change even if the .hi syntax doesn't ProjectName = The Glorious Glasgow Haskell Compilation System ProjectNameShort = ghc @@ -48,14 +54,24 @@ HscMinorVersion=0 CcMajorVersion=36 CcMinorVersion=1 +# Interface file version (hi-boot files only) # -# Interface file version +# A GHC built with HscIfaceFileVersion=n will look for +# M.hi-boot-n, and only then for +# M.hi-boot. +# (It'll be happy with the latter if the former doesn't exist.) # -# If you should happen to make changes to the interface file format -# that will break compatibility with older versions, up this variable. -# +# This variable is used ONLY for hi-boot files. +# Its only purpose is to allow you to have a single directory +# with multiple .hi-boot files for the same module, each +# corresponding to a different version of GHC. +# +# It is propagated to hsc like this: +# * This file is included in ghc/Makefile +# * ghc/Makefile has a main/Constants.lhs-specific flag +# -DHscIfaceFileVersion=$(HscIfaceFileVersion) +# * main/Constants.lhs defines +# interfaceFileFormatVersion = HscIfaceFileVersion +# So there! + HscIfaceFileVersion=5 -# But watch out: interface file format after Simon's renamer -# hacking isn't the same as before, but it may not make -# any difference for the GHC boot files. -# May 1999 diff --git a/ghc/tests/typecheck/should_compile/tc105.hs b/ghc/tests/typecheck/should_compile/tc105.hs index f07fb0df19..891f2c7ab6 100644 --- a/ghc/tests/typecheck/should_compile/tc105.hs +++ b/ghc/tests/typecheck/should_compile/tc105.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fglasgow-exts #-}
+
-- !!! Scoped type variables in result signatures
module ShouldCompile where
|