diff options
82 files changed, 2570 insertions, 2497 deletions
diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 11c16feff7..cec3fa8e28 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -17,7 +17,7 @@ module BasicTypes( Version, Arity, Unused, unused, Fixity(..), FixityDirection(..), StrictnessMark(..), - NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..) + NewOrData(..), TopLevelFlag(..), RecFlag(..) ) where #include "HsVersions.h" @@ -65,39 +65,6 @@ type Version = Int %************************************************************************ %* * -\subsection[IfaceFlavour]{IfaceFlavour} -%* * -%************************************************************************ - -The IfaceFlavour type is used mainly in an imported Name's Provenance -to say whether the name comes from a regular .hi file, or whether it comes -from a hand-written .hi-boot file. This is important, because it has to be -propagated. Suppose - - C.hs imports B - B.hs imports A - A.hs imports C {-# SOURCE -#} ( f ) - -Then in A.hi we may mention C.f, in an inlining. When compiling B we *must not* -read C.f's details from C.hi, even if the latter happens to exist from an earlier -compilation run. So we use the name "C!f" in A.hi, and when looking for an interface -file with details of C!f we look in C.hi-boot. The "!" stuff is recorded in the -IfaceFlavour in the Name of C.f in A. - -Not particularly beautiful, but it works. - -\begin{code} -data IfaceFlavour = HiFile -- The interface was read from a standard interface file - | HiBootFile -- ... or from a handwritten "hi-boot" interface file - -instance Text IfaceFlavour where -- Just used in debug prints of lex tokens - showsPrec n HiFile s = s - showsPrec n HiBootFile s = "!" ++ s -\end{code} - - -%************************************************************************ -%* * \subsection[Fixity]{Fixity info} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 2b8271e95f..61c2086052 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -17,7 +17,7 @@ module Id ( recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible, + setIdName, setIdUnique, setIdType, setIdInfo, -- Predicates omitIfaceSigForId, @@ -70,12 +70,13 @@ import IdInfo import Demand ( Demand ) import Name ( Name, OccName, Module, mkSysLocalName, mkLocalName, - isWiredInName, mkNameVisible + isWiredInName ) import Const ( Con(..) ) import PrimRep ( PrimRep ) import PrimOp ( PrimOp ) import FieldLabel ( FieldLabel(..) ) +import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) import Outputable @@ -109,11 +110,11 @@ mkUserId name ty = mkVanillaId name ty -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... -mkUserLocal :: OccName -> Unique -> Type -> Id +mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id mkSysLocal :: FAST_STRING -> Unique -> Type -> Id -mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty -mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty +mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty +mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -173,11 +174,6 @@ omitIfaceSigForId id other -> False -- Don't omit! \end{code} -\begin{code} -mkIdVisible :: Module -> Id -> Id -mkIdVisible mod id = setIdName id (mkNameVisible mod (idName id)) -\end{code} - %************************************************************************ %* * \subsection{Special Ids} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 669be86bdd..1c6b5d0dbd 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -80,8 +80,9 @@ import List ( nub ) %************************************************************************ \begin{code} -mkSpecPragmaId occ uniq ty - = mkUserLocal occ uniq ty `setInlinePragma` IAmASpecPragmaId +mkSpecPragmaId occ uniq ty loc + = mkUserLocal occ uniq ty loc `setInlinePragma` IAmASpecPragmaId + -- Maybe a SysLocal? But then we'd lose the location mkDefaultMethodId dm_name rec_c ty = mkVanillaId dm_name ty diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 806c9929f1..20b38e918b 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -16,35 +16,35 @@ module Name ( maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, - nameUnique, setNameUnique, setNameProvenance, getNameProvenance, - tidyTopName, mkNameVisible, - nameOccName, nameModule, setNameOcc, + nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason, + tidyTopName, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, isExportedName, nameSrcLoc, isLocallyDefinedName, - isSysLocalName, isLocalName, isGlobalName, isExternallyVisibleName, + isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, - pprNameProvenance, - -- Misc + -- Provenance Provenance(..), ImportReason(..), pprProvenance, ExportFlag(..), PrintUnqualified, + pprNameProvenance, systemProvenance, -- Class NamedThing and overloaded friends NamedThing(..), - modAndOcc, isExported, + isExported, getSrcLoc, isLocallyDefined, getOccString ) where #include "HsVersions.h" -import {-# SOURCE #-} Var ( Id ) -import {-# SOURCE #-} TyCon ( TyCon ) +import {-# SOURCE #-} Var ( Id, setIdName ) +import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) import OccName -- All of it +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual ) import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) -import BasicTypes ( IfaceFlavour(..) ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) import Unique ( pprUnique, Unique, Uniquable(..) ) @@ -60,40 +60,29 @@ import GlaExts %************************************************************************ \begin{code} -data Name - = Local Unique - OccName -- How to print it - Bool -- True <=> this is a "sys-local" - -- see notes just below - - - | Global Unique - Module -- The defining module - OccName -- Its name in that module - Provenance -- How it was defined +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_uniq :: Unique, + n_occ :: OccName, -- Its occurrence name + n_prov :: Provenance -- How it was made + } + +data NameSort + = Local + | Global Module + | WiredInId Module Id + | WiredInTyCon Module TyCon \end{code} -Sys-locals are only used internally. When the compiler generates (say) -a fresh desguar variable it always calls it "ds", and of course it gets -a fresh unique. But when printing -ddump-xx dumps, we must print it with -its unique, because there'll be a lot of "ds" variables. That debug -printing issue is the ONLY way in which sys-locals are different. I think. - -Before anything gets printed in interface files or output code, it's -fed through a 'tidy' processor, which zaps the OccNames to have -unique names; and converts all sys-locals to ordinary locals -If any desugarer sys-locals have survived that far, they get changed to -"ds1", "ds2", etc. - Things with a @Global@ name are given C static labels, so they finally appear in the .o file's symbol table. They appear in the symbol table in the form M.n. If originally-local things have this property they must be made @Global@ first. - \begin{code} -mkLocalName :: Unique -> OccName -> Name -mkLocalName uniq occ = Local uniq occ False +mkLocalName :: Unique -> OccName -> SrcLoc -> Name +mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, + n_prov = LocalDef loc NotExported } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct -- uniques, but the same OccName. Indeed we can, but that's ok @@ -104,10 +93,13 @@ mkLocalName uniq occ = Local uniq occ False -- into the print name (see setNameVisibility below) mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name -mkGlobalName = Global +mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, + n_occ = occ, n_prov = prov } + mkSysLocalName :: Unique -> FAST_STRING -> Name -mkSysLocalName uniq fs = Local uniq (varOcc fs) True +mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, + n_occ = mkSrcVarOcc fs, n_prov = SystemProv } mkTopName :: Unique -> Module -> FAST_STRING -> Name -- Make a top-level name; make it Global if top-level @@ -118,42 +110,72 @@ mkTopName :: Unique -> Module -> FAST_STRING -> Name -- We have to make sure that the name is globally unique -- and we don't have tidyCore to help us. So we append -- the unique. Hack! Hack! -mkTopName uniq mod fs - | all_toplev_ids_visible = Global uniq mod occ (LocalDef noSrcLoc NotExported) - | otherwise = Local uniq occ False - where - occ = varOcc (_PK_ ((_UNPK_ fs) ++ show uniq)) +mkTopName uniq mod fs + = Name { n_uniq = uniq, + n_sort = mk_top_sort mod, + n_occ = mkSrcVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), + n_prov = LocalDef noSrcLoc NotExported } + +------------------------- Wired in names ------------------------- mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name -mkWiredInIdName uniq mod occ id = Global uniq mod occ (WiredInId id) +mkWiredInIdName uniq mod occ id = Name { n_uniq = uniq, n_sort = WiredInId mod id, + n_occ = occ, n_prov = SystemProv } -- mkWiredInTyConName takes a FAST_STRING instead of -- an OccName, which is a bit yukky but that's what the -- clients find easiest. mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name -mkWiredInTyConName uniq mod occ tycon - = Global uniq mod (tcOcc occ) (WiredInTyCon tycon) +mkWiredInTyConName uniq mod fs tycon + = Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon, + n_occ = mkSrcOccFS tcName fs, n_prov = SystemProv } + +fixupSystemName :: Name -> Module -> Provenance -> Name + -- Give the SystemProv name an appropriate provenance, and + -- perhaps change the Moulde too (so that its HiFlag is right) + -- There is a painful hack in that we want to push this + -- better name into an WiredInId/TyCon so that it prints + -- nicely in error messages +fixupSystemName name@(Name {n_sort = Global _}) mod' prov' + = name {n_sort = Global mod', n_prov = prov'} + +fixupSystemName name@(Name {n_sort = WiredInId _ id}) mod' prov' + = name' + where + name' = name {n_sort = WiredInId mod' id', n_prov = prov'} + id' = setIdName id name' +fixupSystemName name@(Name {n_sort = WiredInTyCon _ tc}) mod' prov' + = name' + where + name' = name {n_sort = WiredInTyCon mod' tc', n_prov = prov'} + tc' = setTyConName tc name' + +--------------------------------------------------------------------- mkDerivedName :: (OccName -> OccName) -> Name -- Base name -> Unique -- New unique -> Name -- Result is always a value name -mkDerivedName f (Global _ mod occ prov) uniq = Global uniq mod (f occ) prov -mkDerivedName f (Local _ occ sys) uniq = Local uniq (f occ) sys +mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. -setNameUnique (Local _ occ sys) u = Local u occ sys -setNameUnique (Global _ mod occ prov) u = Global u mod occ prov +setNameUnique name uniq = name {n_uniq = uniq} setNameOcc :: Name -> OccName -> Name -- Give the thing a new OccName, *and* -- record that it's no longer a sys-local -- This is used by the tidy-up pass -setNameOcc (Global uniq mod _ prov) occ = Global uniq mod occ prov -setNameOcc (Local uniq _ sys) occ = Local uniq occ False +setNameOcc name occ = name {n_occ = occ} + +setNameModule :: Name -> Module -> Name +setNameModule name mod = name {n_sort = set (n_sort name)} + where + set (Global _) = Global mod + set (WiredInId _ id) = WiredInId mod id + set (WiredInTyCon _ tycon) = WiredInTyCon mod tycon \end{code} @@ -203,12 +225,13 @@ tidyTopName mod env name -- It should be in the TidyOccEnv already | otherwise = (env', name') where - prov = getNameProvenance name - uniq = nameUnique name - (env', occ') = tidyOccName env (nameOccName name) + (env', occ') = tidyOccName env (n_occ name) + + name' = Name { n_uniq = n_uniq name, n_sort = mk_top_sort mod, + n_occ = occ', n_prov = LocalDef noSrcLoc NotExported } - name' | all_toplev_ids_visible = Global uniq mod occ' prov - | otherwise = Local uniq occ' False +mk_top_sort mod | all_toplev_ids_visible = Global mod + | otherwise = Local all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible @@ -221,22 +244,23 @@ setNameProvenance :: Name -> Provenance -> Name -- Implicit-provenance things, but that gives bad error messages -- for names defined twice in the same module, so I changed it to -- set the provenance of *any* global (SLPJ Jun 97) -setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov -setNameProvenance other_name prov = other_name +setNameProvenance name prov = name {n_prov = prov} getNameProvenance :: Name -> Provenance -getNameProvenance (Global uniq mod occ prov) = prov -getNameProvenance (Local _ _ _) = LocalDef noSrcLoc NotExported -\end{code} +getNameProvenance name = n_prov name -\begin{code} --- make the Name globally visible regardless. -mkNameVisible :: Module -> Name -> Name -mkNameVisible mod nm@(Global _ _ _ _) = nm -mkNameVisible mod nm@(Local uniq occ _) = Global uniq mod g_occ (LocalDef noSrcLoc Exported) +setNameImportReason :: Name -> ImportReason -> Name +setNameImportReason name reason + = name { n_prov = new_prov } where - -- See mkTopName comment. A hack. - g_occ = varOcc (_PK_ (occNameString occ ++ show uniq)) + -- It's important that we don't do the pattern matching + -- in the top-level clause, else we get a black hole in + -- the renamer. Rather a yukky constraint. There's only + -- one call, in RnNames + old_prov = n_prov name + new_prov = case old_prov of + NonLocalDef _ omit -> NonLocalDef reason omit + other -> old_prov \end{code} @@ -248,20 +272,37 @@ mkNameVisible mod nm@(Local uniq occ _) = Global uniq mod g_occ (LocalDef noSrcL \begin{code} data Provenance - = NoProvenance - - | LocalDef -- Defined locally + = LocalDef -- Defined locally SrcLoc -- Defn site ExportFlag -- Whether it's exported | NonLocalDef -- Defined non-locally ImportReason - IfaceFlavour -- Whether the defn site is an .hi-boot file PrintUnqualified - | WiredInTyCon TyCon -- There's a wired-in version - | WiredInId Id -- ...ditto... + | SystemProv -- Either (a) a system-generated local with + -- a v short name OccName + -- or (b) a known-key global which should have a proper + -- provenance attached by the renamer +\end{code} + +Sys-provs are only used internally. When the compiler generates (say) +a fresh desguar variable it always calls it "ds", and of course it gets +a fresh unique. But when printing -ddump-xx dumps, we must print it with +its unique, because there'll be a lot of "ds" variables. + +Names with SystemProv differ in the following ways: + a) locals have unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + c) renamer replaces SystemProv with a better one +Before anything gets printed in interface files or output code, it's +fed through a 'tidy' processor, which zaps the OccNames to have +unique names; and converts all sys-locals to user locals +If any desugarer sys-locals have survived that far, they get changed to +"ds1", "ds2", etc. + +\begin{code} data ImportReason = UserImport Module SrcLoc Bool -- Imported from module M on line L -- Note the M may well not be the defining module @@ -303,18 +344,19 @@ out too. \begin{code} +systemProvenance :: Provenance +systemProvenance = SystemProv + -- pprNameProvenance is used in error messages to say where a name came from pprNameProvenance :: Name -> SDoc pprNameProvenance name = pprProvenance (getNameProvenance name) pprProvenance :: Provenance -> SDoc -pprProvenance NoProvenance = ptext SLIT("No provenance") +pprProvenance SystemProv = ptext SLIT("System") pprProvenance (LocalDef loc _) = ptext SLIT("defined at") <+> ppr loc -pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") -pprProvenance (WiredInId id) = ptext SLIT("Wired-in id") -pprProvenance (NonLocalDef ImplicitImport _ _) +pprProvenance (NonLocalDef ImplicitImport _) = ptext SLIT("implicitly imported") -pprProvenance (NonLocalDef (UserImport mod loc _) _ _) +pprProvenance (NonLocalDef (UserImport mod loc _) _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc \end{code} @@ -327,7 +369,6 @@ pprProvenance (NonLocalDef (UserImport mod loc _) _ _) \begin{code} nameUnique :: Name -> Unique -nameModAndOcc :: Name -> (Module, OccName) -- Globals only nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc @@ -340,59 +381,62 @@ isExternallyVisibleName :: Name -> Bool -nameUnique (Local u _ _) = u -nameUnique (Global u _ _ _) = u +nameUnique name = n_uniq name +nameOccName name = n_occ name -nameOccName (Local _ occ _) = occ -nameOccName (Global _ _ occ _) = occ +nameModule name = nameSortModule (n_sort name) -nameModule (Global _ mod occ _) = mod +nameSortModule (Global mod) = mod +nameSortModule (WiredInId mod _) = mod +nameSortModule (WiredInTyCon mod _) = mod -nameModAndOcc (Global _ mod occ _) = (mod,occ) +nameRdrName :: Name -> RdrName +nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ +nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (nameSortModule sort) occ -isExportedName (Global _ _ _ (LocalDef _ Exported)) = True -isExportedName other = False +isExportedName (Name { n_prov = LocalDef _ Exported }) = True +isExportedName other = False -nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc -nameSrcLoc (Global _ _ _ (NonLocalDef (UserImport _ loc _) _ _)) = loc -nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc -nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc -nameSrcLoc other = noSrcLoc +nameSrcLoc name = provSrcLoc (n_prov name) + +provSrcLoc (LocalDef loc _) = loc +provSrcLoc (NonLocalDef (UserImport _ loc _) _) = loc +provSrcLoc SystemProv = noSrcLoc -isLocallyDefinedName (Local _ _ _) = True -isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True -isLocallyDefinedName other = False +isLocallyDefinedName (Name {n_sort = Local}) = True -- Local (might have SystemProv) +isLocallyDefinedName (Name {n_prov = LocalDef _ _}) = True -- Global, but defined here +isLocallyDefinedName other = False -- Other -- Things the compiler "knows about" are in some sense -- "imported". When we are compiling the module where -- the entities are defined, we need to be able to pick -- them out, often in combination with isLocallyDefined. -isWiredInName (Global _ _ _ (WiredInTyCon _)) = True -isWiredInName (Global _ _ _ (WiredInId _)) = True -isWiredInName _ = False +isWiredInName (Name {n_sort = WiredInTyCon _ _}) = True +isWiredInName (Name {n_sort = WiredInId _ _}) = True +isWiredInName _ = False maybeWiredInIdName :: Name -> Maybe Id -maybeWiredInIdName (Global _ _ _ (WiredInId id)) = Just id -maybeWiredInIdName other = Nothing +maybeWiredInIdName (Name {n_sort = WiredInId _ id}) = Just id +maybeWiredInIdName other = Nothing maybeWiredInTyConName :: Name -> Maybe TyCon -maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc)) = Just tc -maybeWiredInTyConName other = Nothing - +maybeWiredInTyConName (Name {n_sort = WiredInTyCon _ tc}) = Just tc +maybeWiredInTyConName other = Nothing -isLocalName (Local _ _ _) = True -isLocalName _ = False -isSysLocalName (Local _ _ sys) = sys -isSysLocalName other = False +isLocalName (Name {n_sort = Local}) = True +isLocalName _ = False -isGlobalName (Global _ _ _ _) = True -isGlobalName other = False +isGlobalName (Name {n_sort = Local}) = False +isGlobalName other = True -- Global names are by definition those that are visible -- outside the module, *as seen by the linker*. Externally visible -- does not mean visible at the source level (that's isExported). isExternallyVisibleName name = isGlobalName name + +isSystemName (Name {n_prov = SystemProv}) = True +isSystemName other = False \end{code} @@ -403,12 +447,7 @@ isExternallyVisibleName name = isGlobalName name %************************************************************************ \begin{code} -cmpName n1 n2 = c n1 n2 - where - c (Local u1 _ _) (Local u2 _ _) = compare u1 u2 - c (Local _ _ _) _ = LT - c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2 - c (Global _ _ _ _) _ = GT +cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 \end{code} \begin{code} @@ -442,7 +481,8 @@ instance Outputable Name where -- When printing interfaces, all Locals have been given nice print-names ppr name = pprName name -pprName (Local uniq occ sys_local) +pprName (Name {n_sort = Local, n_uniq = uniq, n_occ = occ, n_prov = prov}) + -- Locals = getPprStyle $ \ sty -> if codeStyle sty then pprUnique uniq -- When printing in code we required all names to @@ -451,38 +491,52 @@ pprName (Local uniq occ sys_local) else pprOccName occ <> pp_local_extra sty uniq where + sys_local = case prov of + SystemProv -> True + other -> False + pp_local_extra sty uniq | sys_local = underscore <> pprUnique uniq -- Must print uniques for sys_locals | debugStyle sty = text "{-" <> pprUnique uniq <> text "-}" | otherwise = empty -pprName (Global uniq mod occ prov) +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) + -- Globals, and wired in things = getPprStyle $ \ sty -> if codeStyle sty then ppr mod <> underscore <> ppr occ else pp_mod_dot sty <> ppr occ <> pp_global_debug sty uniq prov where + mod = nameSortModule sort + pp_mod_dot sty - = case prov of -- Omit home module qualifier if in scope - LocalDef _ _ -> pp_qual dot (user_sty || iface_sty) - NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty) - -- Hack: omit qualifers on wired in things - -- in user style only - WiredInTyCon _ -> pp_qual dot user_sty - WiredInId _ -> pp_qual dot user_sty - NoProvenance -> pp_qual dot False + = case prov of + SystemProv -> pp_qual mod dot user_sty + -- Hack alert! Omit the qualifier on SystemProv things, which I claim + -- will also be WiredIn things. We can't get the omit flag right + -- on wired in tycons etc (sigh) so we just leave it out in user style, + -- and hope that leaving it out isn't too consfusing. + -- (e.g. if the programmer hides Bool and redefines it. If so, use -dppr-debug.) + + LocalDef _ _ -> pp_qual mod dot (user_sty || iface_sty) + + NonLocalDef (UserImport imp_mod _ _) omit + | user_sty -> pp_qual imp_mod pp_sep omit + | otherwise -> pp_qual mod pp_sep False + NonLocalDef ImplicitImport omit -> pp_qual mod pp_sep (user_sty && omit) where user_sty = userStyle sty iface_sty = ifaceStyle sty - pp_qual sep omit_qual + pp_qual mod sep omit_qual | omit_qual = empty - | otherwise = pprModule mod <> sep + | otherwise = pprModule mod <> sep - pp_hif HiFile = dot -- Vanilla case - pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface + pp_sep | bootFlavour (moduleIfaceFlavour mod) = text "!" -- M!t indicates a name imported + -- from a .hi-boot interface + | otherwise = dot -- Vanilla case pp_global_debug sty uniq prov | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"] @@ -491,13 +545,12 @@ pprName (Global uniq mod occ prov) prov_p prov | opt_PprStyle_NoPrags = empty | otherwise = comma <> pp_prov prov -pp_prov (LocalDef _ Exported) = char 'x' -pp_prov (LocalDef _ NotExported) = char 'l' -pp_prov (NonLocalDef ImplicitImport _ _) = char 'i' -pp_prov (NonLocalDef explicitimport _ _) = char 'I' -pp_prov (WiredInTyCon _) = char 'W' -pp_prov (WiredInId _) = char 'w' -pp_prov NoProvenance = char '?' +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef ImplicitImport _) = char 'j' +pp_prov (NonLocalDef (UserImport _ _ True ) _) = char 'I' -- Imported by name +pp_prov (NonLocalDef (UserImport _ _ False) _) = char 'i' -- Imported by .. +pp_prov SystemProv = char 's' \end{code} @@ -509,20 +562,18 @@ pp_prov NoProvenance = char '?' \begin{code} class NamedThing a where - getOccName :: a -> OccName -- Even RdrNames can do this! + getOccName :: a -> OccName getName :: a -> Name getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -modAndOcc :: NamedThing a => a -> (Module, OccName) getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool isExported :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String -modAndOcc = nameModAndOcc . getName isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 499363fa86..cba9b4fb89 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -8,84 +8,225 @@ module OccName ( -- Modules Module, -- Abstract, instance of Outputable - mkModule, mkModuleFS, moduleString, moduleCString, pprModule, + mkSrcModule, mkSrcModuleFS, mkSysModuleFS, mkImportModuleFS, mkBootModule, mkIfaceModuleFS, + moduleString, moduleUserString, moduleIfaceFlavour, + pprModule, pprModuleSep, pprModuleBoot, + + -- IfaceFlavour + IfaceFlavour, + hiFile, hiBootFile, bootFlavour, + + -- The NameSpace type; abstact + NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName, + nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable - varOcc, tcOcc, tvOcc, -- Occ constructors - srcVarOcc, srcTCOcc, srcTvOcc, -- For Occs arising from source code + pprOccName, - mkSuperDictSelOcc, mkDFunOcc, - mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkClassTyConOcc, mkClassDataConOcc, + mkSrcOccFS, mkSysOcc, mkSysOccFS, mkSrcVarOcc, mkKindOccFS, + mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, + mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, + mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc, - isWildCardOcc, isAnonOcc, - pprOccName, occNameString, occNameFlavour, + isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, + + occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, + setOccNameSpace, - -- The basic form of names - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - isLowerISO, isUpperISO, - -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, - -- Junk - identToC + -- Encoding + EncodedString, EncodedFS, UserString, UserFS, encode, encodeFS, decode, + + -- The basic form of names + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + isLowerISO, isUpperISO ) where #include "HsVersions.h" -import Char ( isAlpha, isUpper, isLower, ISALPHANUM, ord ) +import Char ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt, intToDigit ) import Util ( thenCmp ) import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) import Outputable import GlaExts \end{code} +We hold both module names and identifier names in a 'Z-encoded' form +that makes them acceptable both as a C identifier and as a Haskell +(prefix) identifier. + +They can always be decoded again when printing error messages +or anything else for the user, but it does make sense for it +to be represented here in encoded form, so that when generating +code the encoding operation is not performed on each occurrence. + +These type synonyms help documentation. + +\begin{code} +type UserFS = FAST_STRING -- As the user typed it +type EncodedFS = FAST_STRING -- Encoded form + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +pprEncodedFS :: EncodedFS -> SDoc +pprEncodedFS fs + = getPprStyle $ \ sty -> + if userStyle sty then + text (decode (_UNPK_ fs)) + else + ptext fs +\end{code} + %************************************************************************ %* * -\subsection[Module]{The name of a module} +\subsection{Interface file flavour} %* * %************************************************************************ +The IfaceFlavour type is used mainly in an imported Name's Provenance +to say whether the name comes from a regular .hi file, or whether it comes +from a hand-written .hi-boot file. This is important, because it has to be +propagated. Suppose + + C.hs imports B + B.hs imports A + A.hs imports C {-# SOURCE -#} ( f ) + +Then in A.hi we may mention C.f, in an inlining. When compiling B we *must not* +read C.f's details from C.hi, even if the latter happens to exist from an earlier +compilation run. So we use the name "C!f" in A.hi, and when looking for an interface +file with details of C!f we look in C.hi-boot. The "!" stuff is recorded in the +IfaceFlavour in the Module of C.f in A. + +Not particularly beautiful, but it works. + \begin{code} -data Module = Module FAST_STRING -- User and interface files - FAST_STRING -- Print this in C files +data IfaceFlavour = HiFile -- The thing comes from a standard interface file + -- or from the source file itself + | HiBootFile -- ... or from a handwritten "hi-boot" interface file + deriving( Eq ) + +hiFile = HiFile +hiBootFile = HiBootFile + +instance Text IfaceFlavour where -- Just used in debug prints of lex tokens + showsPrec n HiFile s = s + showsPrec n HiBootFile s = "!" ++ s + +bootFlavour :: IfaceFlavour -> Bool +bootFlavour HiBootFile = True +bootFlavour HiFile = False +\end{code} + + +%************************************************************************ +%* * +\subsection[Module]{The name of a module} +%* * +%************************************************************************ - -- The C version has quote chars Z-encoded +\begin{code} +data Module = Module + EncodedFS + IfaceFlavour + -- Haskell module names can include the quote character ', + -- so the module names have the z-encoding applied to them +\end{code} +\begin{code} instance Outputable Module where ppr = pprModule +-- Ignore the IfaceFlavour when comparing modules instance Eq Module where (Module m1 _) == (Module m2 _) = m1 == m2 instance Ord Module where (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2 +\end{code} + +\begin{code} pprModule :: Module -> SDoc -pprModule (Module real code) - = getPprStyle $ \ sty -> - if codeStyle sty then - ptext code - else - ptext real +pprModule (Module mod _) = pprEncodedFS mod -mkModule :: String -> Module -mkModule s = Module (_PK_ s) (identToC s) +pprModuleSep, pprModuleBoot :: Module -> SDoc +pprModuleSep (Module mod HiFile) = dot +pprModuleSep (Module mod HiBootFile) = char '!' -mkModuleFS :: FAST_STRING -> Module -mkModuleFS s = Module s (identFsToC s) +pprModuleBoot (Module mod HiFile) = empty +pprModuleBoot (Module mod HiBootFile) = char '!' +\end{code} + + +\begin{code} +mkSrcModule :: UserString -> Module +mkSrcModule s = Module (_PK_ (encode s)) HiFile -moduleString :: Module -> String +mkSrcModuleFS :: UserFS -> Module +mkSrcModuleFS s = Module (encodeFS s) HiFile + +mkImportModuleFS :: UserFS -> IfaceFlavour -> Module +mkImportModuleFS s hif = Module (encodeFS s) hif + +mkSysModuleFS :: EncodedFS -> IfaceFlavour -> Module +mkSysModuleFS s hif = Module s hif + +mkIfaceModuleFS :: EncodedFS -> Module +mkIfaceModuleFS s = Module s HiFile + +mkBootModule :: Module -> Module +mkBootModule (Module s _) = Module s HiBootFile + +moduleString :: Module -> EncodedString moduleString (Module mod _) = _UNPK_ mod -moduleCString :: Module -> String -moduleCString (Module _ code) = _UNPK_ code +moduleUserString :: Module -> UserString +moduleUserString (Module mod _) = decode (_UNPK_ mod) + +moduleIfaceFlavour :: Module -> IfaceFlavour +moduleIfaceFlavour (Module _ hif) = hif +\end{code} + + +%************************************************************************ +%* * +\subsection{Name space} +%* * +%************************************************************************ + +\begin{code} +data NameSpace = VarName -- Variables + | DataName -- Data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +tvName = TvName +varName = VarName + + +nameSpaceString :: NameSpace -> String +nameSpaceString DataName = "Data constructor" +nameSpaceString VarName = "Variable" +nameSpaceString TvName = "Type variable" +nameSpaceString TcClsName = "Type constructor or class" \end{code} @@ -96,44 +237,19 @@ moduleCString (Module _ code) = _UNPK_ code %************************************************************************ \begin{code} -data OccName = OccName - OccSpace - FAST_STRING -- The 'real name' - FAST_STRING -- Print this in interface files - FAST_STRING -- Print this in C/asm code - --- The OccSpace/real-name pair define the OccName --- The iface and c/asm versions are simply derived from the --- other two. They are cached here simply to avoid recomputing --- them repeatedly when printing - --- The latter two are irrelevant in RdrNames; on the other hand, --- the OccSpace field is irrelevant after RdrNames. --- So the OccName type might be refined a bit. --- It is now abstract so that's easier than before - - --- Why three print-names? --- Real Iface C --- --------------------- --- foo foo foo --- --- + + Zp Operators OK in interface files; --- 'Z' is the escape char for C names --- --- x# x# xZh Trailing # lexed ok by GHC -fglasgow-exts --- --- _foo _ufoo _ufoo Leading '_' is the escape char in interface files --- --- _vfoo _vfoo _vfoo Worker for foo --- --- _wp _wp _wp Worker for + - - -data OccSpace = VarOcc -- Variables and data constructors - | TvOcc -- Type variables - | TCOcc -- Type constructors and classes - deriving( Eq, Ord ) +data OccName = OccName + NameSpace + EncodedFS +\end{code} + + +\begin{code} +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` + (sp1 `compare` sp2) \end{code} @@ -145,17 +261,10 @@ data OccSpace = VarOcc -- Variables and data constructors \begin{code} instance Outputable OccName where - ppr = pprOccName + ppr = pprOccName pprOccName :: OccName -> SDoc -pprOccName (OccName space real iface code) - = getPprStyle $ \ sty -> - if codeStyle sty then - ptext code - else if ifaceStyle sty then - ptext iface - else - ptext real +pprOccName (OccName sp occ) = pprEncodedFS occ \end{code} @@ -164,122 +273,142 @@ pprOccName (OccName space real iface code) \subsection{Construction} %* * %************************************************************************ - -*Source-code* things beginning with '_' are zapped to begin with '_u' -\begin{code} -mkSrcOcc :: OccSpace -> FAST_STRING -> OccName -mkSrcOcc occ_sp real - = case _UNPK_ real of +*Sys* things do no encoding; the caller should ensure that the thing is +already encoded - '_' : rest -> OccName occ_sp real (_PK_ zapped_str) (identToC zapped_str) - where - zapped_str = '_' : 'u' : rest - - other -> OccName occ_sp real real (identFsToC real) - -srcVarOcc, srcTCOcc, srcTvOcc :: FAST_STRING -> OccName -srcVarOcc = mkSrcOcc VarOcc -srcTCOcc = mkSrcOcc TCOcc -srcTvOcc = mkSrcOcc TvOcc +\begin{code} +mkSysOcc :: NameSpace -> EncodedString -> OccName +mkSysOcc occ_sp str = ASSERT( alreadyEncoded str ) + OccName occ_sp (_PK_ str) + +mkSysOccFS :: NameSpace -> EncodedFS -> OccName +mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs ) + OccName occ_sp fs + +-- Kind constructors get a speical function. Uniquely, they are not encoded, +-- so that they have names like '*'. This means that *even in interface files* +-- we'll get kinds like (* -> (* -> *)). We can't use mkSysOcc because it +-- has an ASSERT that doesn't hold. +mkKindOccFS :: NameSpace -> EncodedFS -> OccName +mkKindOccFS occ_sp fs = OccName occ_sp fs \end{code} -However, things that don't come from Haskell source code aren't -treated specially. +*Source-code* things are encoded. \begin{code} -mkOcc :: OccSpace -> String -> OccName -mkOcc occ_sp str = OccName occ_sp fs fs (identToC str) - where - fs = _PK_ str - -mkFsOcc :: OccSpace -> FAST_STRING -> OccName -mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real) +mkSrcOccFS :: NameSpace -> UserFS -> OccName +mkSrcOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs) -varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName -varOcc = mkFsOcc VarOcc -tcOcc = mkFsOcc TCOcc -tvOcc = mkFsOcc TvOcc +mkSrcVarOcc :: UserFS -> OccName +mkSrcVarOcc fs = mkSysOccFS varName (encodeFS fs) \end{code} + %************************************************************************ %* * -\subsection{Making system names} +\subsection{Predicates and taking them apart} %* * %************************************************************************ -Here's our convention for splitting up the interface file name space: +\begin{code} +occNameFS :: OccName -> EncodedFS +occNameFS (OccName _ s) = s - _d... dictionary identifiers +occNameString :: OccName -> EncodedString +occNameString (OccName _ s) = _UNPK_ s - _f... dict-fun identifiers (from inst decls) - _g... ditto, when the tycon has symbols +occNameUserString :: OccName -> UserString +occNameUserString occ = decode (occNameString occ) - _t... externally visible (non-user visible) names +occNameSpace :: OccName -> NameSpace +occNameSpace (OccName sp _) = sp - _m... default methods - _n... default methods (encoded symbols, eg. <= becomes _nle) +setOccNameSpace :: OccName -> NameSpace -> OccName +setOccNameSpace (OccName _ occ) sp = OccName sp occ - _p... superclass selectors +-- occNameFlavour is used only to generate good error messages +occNameFlavour :: OccName -> String +occNameFlavour (OccName sp _) = nameSpaceString sp +\end{code} - _v... workers - _w... workers (encoded symbols) +\begin{code} +isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool - _x... local variables +isTvOcc (OccName TvName _) = True +isTvOcc other = False - _u... user-defined names that previously began with '_' +-- Data constructor operator (starts with ':', or '[]') +-- Pretty inefficient! +isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s) +isDataSymOcc other = False - _T... compiler-generated tycons for dictionaries - _D.. ...ditto data cons +isDataOcc (OccName DataName _) = True +isDataOcc oter = False - __.... keywords (__export, __letrec etc.) +-- Any operator (data constructor or variable) +-- Pretty inefficient! +isSymOcc (OccName DataName s) = isLexConSym (decodeFS s) +isSymOcc (OccName VarName s) = isLexSym (decodeFS s) +\end{code} -This knowledge is encoded in the following functions. +%************************************************************************ +%* * +\subsection{Making system names} +%* * +%************************************************************************ +Here's our convention for splitting up the interface file name space: + d... dictionary identifiers + (local variables, so no name-clash worries) -@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@; - eg: workers, derived methods + $f... dict-fun identifiers (from inst decls) + $m... default methods + $p... superclass selectors + $w... workers + $T... compiler-generated tycons for dictionaries + $D... ...ditto data cons + $sf.. specialised version of f -We pass a character to use as the prefix. So, for example, - "f" gets derived to "_vf", if the prefix char is 'v' + in encoded form these appear as Zdfxxx etc -\begin{code} -mk_deriv :: OccSpace -> Char -> String -> OccName -mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str) -\end{code} + :... keywords (export:, letrec: etc.) -Things are a bit more complicated if the thing is an operator; then -we must encode it into a normal identifier first. We do this in -a simple way, and use a different character prefix (one after the one -suggested). For example - "<" gets derived to "_wl", if the prefix char is 'v' +This knowledge is encoded in the following functions. + + +@mk_deriv@ generates an @OccName@ from the one-char prefix and a string. +NB: The string must already be encoded! \begin{code} -mk_enc_deriv :: OccSpace - -> Char -- The system-name-space character (see list above) - -> OccName -- The OccName from which we are deriving - -> OccName - -mk_enc_deriv occ_sp sys_ch occ - | needs_encoding real_str = mk_deriv occ_sp sys_op_ch (encode_operator real_str) - | otherwise = mk_deriv occ_sp sys_ch real_str - where - real_str = occNameString occ - sys_op_ch = succ sys_ch +mk_deriv :: NameSpace + -> String -- Distinguishes one sort of derived name from another + -> EncodedString -- Must be already encoded!! We don't want to encode it a + -- second time because encoding isn't itempotent + -> OccName +mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str) +\end{code} -mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkClassTyConOcc, mkClassDataConOcc +\begin{code} +mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, + mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc :: OccName -> OccName -mkWorkerOcc = mk_enc_deriv VarOcc 'v' -- v,w -mkDefaultMethodOcc = mk_enc_deriv VarOcc 'm' -- m,n -mkClassTyConOcc = mk_enc_deriv TCOcc 'T' -- not U -mkClassDataConOcc = mk_enc_deriv VarOcc 'D' -- not E -mkDictOcc = mk_enc_deriv VarOcc 'd' -- not e +-- These derived variables have a prefix that no Haskell value could have +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMethodOcc = mk_simple_deriv varName "$m" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassTyConOcc = mk_simple_deriv tcName ":T" -- The : prefix makes sure it classifies +mkClassDataConOcc = mk_simple_deriv dataName ":D" -- as a tycon/datacon +mkDictOcc = mk_simple_deriv varName "$d" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" + +mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) \end{code} \begin{code} @@ -287,7 +416,7 @@ mkSuperDictSelOcc :: Int -- Index of superclass, eg 3 -> OccName -- Class, eg "Ord" -> OccName -- eg "p3Ord" mkSuperDictSelOcc index cls_occ - = mk_deriv VarOcc 'p' (show index ++ occNameString cls_occ) + = mk_deriv varName "$p" (show index ++ occNameString cls_occ) \end{code} @@ -300,14 +429,10 @@ mkDFunOcc :: OccName -- class, eg "Ord" -> OccName -- "dOrdMaybe3" mkDFunOcc cls_occ tycon_occ index - | needs_encoding tycon_str -- Drat! Have to encode the tycon - = mk_deriv VarOcc 'g' (show_index ++ cls_str ++ encode_operator tycon_str) - | otherwise -- Normal case - = mk_deriv VarOcc 'f' (show_index ++ cls_str ++ tycon_str) + = mk_deriv VarName "$f" (show_index ++ cls_str ++ tycon_str) where cls_str = occNameString cls_occ tycon_str = occNameString tycon_occ - -- NB: if a non-operator the tycon has a trailing # we don't encode. show_index | index == 0 = "" | otherwise = show index \end{code} @@ -315,131 +440,6 @@ mkDFunOcc cls_occ tycon_occ index %************************************************************************ %* * -\subsection{Lexical categories} -%* * -%************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -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 - -isLexVarId cs -- Ordinary prefix identifiers - | _NULL_ cs = False -- e.g. "x", "_x" - | otherwise = isLower c || isLowerISO c || c == '_' - where - c = _HEAD_ cs - -isLexConSym cs -- Infix type or data constructors - | _NULL_ cs = False -- e.g. ":-:", ":", "->" - | otherwise = c == ':' - || cs == SLIT("->") - where - c = _HEAD_ cs - -isLexVarSym cs -- Infix identifiers - | _NULL_ cs = False -- e.g. "+" - | otherwise = isSymbolASCII c - || isSymbolISO c - where - c = _HEAD_ cs - -------------- -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'# - --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# - --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c -\end{code} - -%************************************************************************ -%* * -\subsection{Predicates and taking them apart} -%* * -%************************************************************************ - -\begin{code} -occNameString :: OccName -> String -occNameString (OccName _ s _ _) = _UNPK_ s - --- occNameFlavour is used only to generate good error messages, so it doesn't matter --- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for --- data constructors and values, but that makes everything else a bit more complicated. -occNameFlavour :: OccName -> String -occNameFlavour (OccName VarOcc s _ _) | isLexConId s = "Data constructor" - | otherwise = "Value" -occNameFlavour (OccName TvOcc _ _ _) = "Type variable" -occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class" - -isVarOcc, isTCOcc, isTvOcc, - isConSymOcc, isSymOcc, isWildCardOcc :: OccName -> Bool - -isVarOcc (OccName VarOcc _ _ _) = True -isVarOcc other = False - -isTvOcc (OccName TvOcc _ _ _) = True -isTvOcc other = False - -isTCOcc (OccName TCOcc _ _ _) = True -isTCOcc other = False - -isConSymOcc (OccName _ s _ _) = isLexConSym s - -isSymOcc (OccName _ s _ _) = isLexSym s - -isConOcc (OccName _ s _ _) = isLexCon s - -isWildCardOcc (OccName _ s _ _) = (_HEAD_ s) == '_' && _LENGTH_ s == 1 - -isAnonOcc (OccName _ s _ _) = (_HEAD_ s) == '_' -\end{code} - - -%************************************************************************ -%* * -\subsection{Comparison} -%* * -%************************************************************************ - -Comparison is done by space and 'real' name - -\begin{code} -instance Eq OccName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord OccName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - compare (OccName sp1 r1 _ _) (OccName sp2 r2 _ _) - = (sp1 `compare` sp2) `thenCmp` (r1 `compare` r2) -\end{code} - - -%************************************************************************ -%* * \subsection{Tidying them up} %* * %************************************************************************ @@ -460,24 +460,16 @@ type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames emptyTidyOccEnv = emptyFM initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOccEnv +initTidyOccEnv = foldl (\env (OccName _ fs) -> addToFM env fs 1) emptyTidyOccEnv tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) -tidyOccName in_scope occ@(OccName occ_sp real _ _) - | not (real `elemFM` in_scope) && - not (isLexCon real) -- Hack alert! Specialised versions of overloaded - -- constructors end up as ordinary Ids, but we don't - -- want them as ConIds in interface files. - - = (addToFM in_scope real 1, occ) -- First occurrence +tidyOccName in_scope occ@(OccName occ_sp fs) + | not (fs `elemFM` in_scope) + = (addToFM in_scope fs 1, occ) -- First occurrence | otherwise -- Already occurs - = -- First encode, to deal with - -- a) operators, and - -- b) trailing # signs - -- so that we can then append '1', '2', etc - go in_scope (encode_operator (_UNPK_ real)) + = go in_scope (_UNPK_ fs) where go in_scope str = case lookupFM in_scope pk_str of @@ -485,7 +477,7 @@ tidyOccName in_scope occ@(OccName occ_sp real _ _) -- Need to go round again, just in case "t3" (say) -- clashes with a "t3" that's already in scope - Nothing -> (addToFM in_scope pk_str 1, mkFsOcc occ_sp pk_str) + Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str) -- str is now unique where pk_str = _PK_ str @@ -494,110 +486,224 @@ tidyOccName in_scope occ@(OccName occ_sp real _ _) %************************************************************************ %* * -\subsection{Encoding for operators in derived names} +\subsection{The 'Z' encoding} %* * %************************************************************************ -See comments with mk_enc_deriv +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is the name +by which things are known right through the compiler. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower), digits, and '_' + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'Zx' for some + alphabetic character x + +* The others translate as 'Zxdd' where 'dd' is exactly two hexadecimal + digits for the ord of the character + + Before After + -------------------------- + Trak Trak + foo_wib foo_wib + > Zg + >1 Zg1 + foo# fooZh + foo## fooZhZh + foo##1 fooZhXh1 + fooZ fooZZ + :+ ZcZp + () Z0T + (,,,,) Z4T + \begin{code} -needs_encoding :: String -> Bool -- Needs encoding when embedded in a derived name - -- Just look at the first character -needs_encoding (c:cs) = not (isAlpha c || c == '_') - -encode_operator :: String -> String -encode_operator nm = foldr tran "" nm - where - tran c cs = case trChar c of - '\0' -> '_' : show (ord c) ++ cs -- No translation - tr_c -> tr_c : cs - - trChar '&' = 'a' - trChar '|' = 'b' - trChar ':' = 'c' - trChar '/' = 'd' - trChar '=' = 'e' - trChar '>' = 'g' - trChar '#' = 'h' - trChar '@' = 'i' - trChar '<' = 'l' - trChar '-' = 'm' - trChar '!' = 'n' - trChar '+' = 'p' - trChar '\'' = 'q' - trChar '$' = 'r' - trChar '?' = 's' - trChar '*' = 't' - trChar '_' = 'u' - trChar '.' = 'v' - trChar '\\' = 'w' - trChar '%' = 'x' - trChar '~' = 'y' - trChar '^' = 'z' - trChar _ = '\0' -- No translation +-- alreadyEncoded is used in ASSERTs to check for encoded +-- strings. It isn't fail-safe, of course, because, say 'zh' might +-- be encoded or not. +alreadyEncoded :: String -> Bool +alreadyEncoded s = all ok s + where + ok '_' = True + ok ch = ISALPHANUM ch + +alreadyEncodedFS :: FAST_STRING -> Bool +alreadyEncodedFS fs = alreadyEncoded (_UNPK_ fs) + +encode :: UserString -> EncodedString +encode cs = case maybe_tuple cs of + Just n -> 'Z' : show n ++ "T" -- Tuples go to Z2T etc + Nothing -> go cs + where + go [] = [] + go (c:cs) = encode_ch c ++ go cs + +-- ToDo: Unboxed tuples too, perhaps? +maybe_tuple ('(' : cs) = check_tuple 0 cs +maybe_tuple other = Nothing + +check_tuple n (',' : cs) = check_tuple (n+1) cs +check_tuple n ")" = Just n +check_tuple n other = Nothing + +encodeFS :: UserFS -> EncodedFS +encodeFS fast_str | all unencodedChar str = fast_str + | otherwise = _PK_ (encode str) + where + str = _UNPK_ fast_str + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar '_' = True +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = ISALPHANUM c + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch c = ['z', 'x', intToDigit hi, intToDigit lo] + where + (hi,lo) = ord c `quotRem` 16 +\end{code} + +Decode is used for user printing. + +\begin{code} +decodeFS :: FAST_STRING -> FAST_STRING +decodeFS fs = _PK_ (decode (_UNPK_ fs)) + +decode :: EncodedString -> UserString +decode [] = [] +decode ('Z' : rest) = decode_escape rest +decode ('z' : rest) = decode_escape rest +decode (c : rest) = c : decode rest + +decode_escape :: EncodedString -> UserString + +decode_escape ('Z' : rest) = 'Z' : decode rest +decode_escape ('C' : rest) = ':' : decode rest +decode_escape ('L' : rest) = '(' : decode rest +decode_escape ('R' : rest) = ')' : decode rest +decode_escape ('M' : rest) = '[' : decode rest +decode_escape ('N' : rest) = ']' : decode rest + +decode_escape ('z' : rest) = 'z' : decode rest +decode_escape ('a' : rest) = '&' : decode rest +decode_escape ('b' : rest) = '|' : decode rest +decode_escape ('d' : rest) = '$' : decode rest +decode_escape ('e' : rest) = '=' : decode rest +decode_escape ('g' : rest) = '>' : decode rest +decode_escape ('h' : rest) = '#' : decode rest +decode_escape ('i' : rest) = '.' : decode rest +decode_escape ('l' : rest) = '<' : decode rest +decode_escape ('m' : rest) = '-' : decode rest +decode_escape ('n' : rest) = '!' : decode rest +decode_escape ('p' : rest) = '+' : decode rest +decode_escape ('q' : rest) = '\'' : decode rest +decode_escape ('r' : rest) = '\\' : decode rest +decode_escape ('s' : rest) = '/' : decode rest +decode_escape ('t' : rest) = '*' : decode rest +decode_escape ('x' : d1 : d2 : rest) = chr (digitToInt d1 * 16 + digitToInt d2) : decode rest + +-- Tuples are coded as Z23T +decode_escape (c : rest) + | isDigit c = go (digitToInt c) rest + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go n ('T' : rest) = '(' : replicate n ',' ++ ')' : decode rest + go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest)) + +decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest) \end{code} %************************************************************************ %* * -\subsection{The 'Z' encoding} +n\subsection{Lexical categories} %* * %************************************************************************ -We provide two interfaces for efficiency. +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. \begin{code} -identToC :: String -> FAST_STRING -identToC str - | all ISALPHANUM str && not std = _PK_ str - | std = _PK_ ("Zs" ++ encode str) - | otherwise = _PK_ (encode str) - where - std = has_std_prefix str +isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool -identFsToC :: FAST_STRING -> FAST_STRING -identFsToC fast_str - | all ISALPHANUM str && not std = fast_str - | std = _PK_ ("Zs" ++ encode str) - | otherwise = _PK_ (encode str) - where - std = has_std_prefix str - str = _UNPK_ fast_str +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs --- avoid "stdin", "stdout", and "stderr"... -has_std_prefix ('s':'t':'d':_) = True -has_std_prefix _ = False +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs -encode :: String -> String -encode [] = [] -encode (c:cs) = encode_ch c ++ encode cs +------------- -encode_ch :: Char -> String -encode_ch c | ISALPHANUM c = [c] - -- Common case first -encode_ch 'Z' = "ZZ" -encode_ch '&' = "Za" -encode_ch '|' = "Zb" -encode_ch ':' = "Zc" -encode_ch '/' = "Zd" -encode_ch '=' = "Ze" -encode_ch '>' = "Zg" -encode_ch '#' = "Zh" -encode_ch '<' = "Zl" -encode_ch '-' = "Zm" -encode_ch '!' = "Zn" -encode_ch '.' = "Zs" -encode_ch '\'' = "Zq" -encode_ch '*' = "Zt" -encode_ch '+' = "Zp" -encode_ch '_' = "_" -encode_ch c = 'Z':show (ord c) -\end{code} +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 -For \tr{modnameToC}, we really only have to worry about \tr{'}s -(quote chars) in the name. Rare. +isLexVarId cs -- Ordinary prefix identifiers + | _NULL_ cs = False -- e.g. "x", "_x" + | otherwise = isLower c || isLowerISO c || c == '_' + where + c = _HEAD_ cs -\begin{code} -modnameToC :: FAST_STRING -> FAST_STRING -modnameToC fast_str = identFsToC fast_str +isLexConSym cs -- Infix type or data constructors + | _NULL_ cs = False -- e.g. ":-:", ":", "->" + | otherwise = c == ':' + || cs == SLIT("->") + where + c = _HEAD_ cs + +isLexVarSym cs -- Infix identifiers + | _NULL_ cs = False -- e.g. "+" + | otherwise = isSymbolASCII c + || isSymbolISO c + where + c = _HEAD_ cs + +------------- +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'# + --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c +isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# + --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 6962b92733..5ebb9e6801 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -28,6 +28,7 @@ module SrcLoc ( #include "HsVersions.h" +import Util ( thenCmp ) import Outputable import FastString ( unpackFS ) import GlaExts ( Int(..), (+#) ) @@ -49,19 +50,6 @@ data SrcLoc FAST_INT | UnhelpfulSrcLoc FAST_STRING -- Just a general indication - -instance Ord SrcLoc where - compare NoSrcLoc NoSrcLoc = EQ - compare NoSrcLoc _ = GT - compare (UnhelpfulSrcLoc _) (UnhelpfulSrcLoc _) = EQ - compare (UnhelpfulSrcLoc _) _ = GT - compare _ NoSrcLoc = LT - compare _ (UnhelpfulSrcLoc _) = LT - compare (SrcLoc _ y1) (SrcLoc _ y2) = compare IBOX(y1) IBOX(y2) - -instance Eq SrcLoc where - (==) x y = compare x y == EQ - \end{code} Note that an entity might be imported via more than one route, and @@ -102,6 +90,29 @@ incSrcLine loc = loc %************************************************************************ \begin{code} +-- SrcLoc is an instance of Ord so that we can sort error messages easily +instance Eq SrcLoc where + loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of + EQ -> True + other -> False + +instance Ord SrcLoc where + compare = cmpSrcLoc + +cmpSrcLoc NoSrcLoc NoSrcLoc = EQ +cmpSrcLoc NoSrcLoc other = LT + +cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2 +cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT + +cmpSrcLoc (SrcLoc s1 l1) NoSrcLoc = GT +cmpSrcLoc (SrcLoc s1 l1) (UnhelpfulSrcLoc _) = LT +cmpSrcLoc (SrcLoc s1 l1) (SrcLoc s2 l2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) + where + l1 `cmpline` l2 | l1 <# l2 = LT + | l1 ==# l2 = EQ + | otherwise = GT + instance Outputable SrcLoc where ppr (SrcLoc src_path src_line) = getPprStyle $ \ sty -> diff --git a/ghc/compiler/basicTypes/Var.hi-boot b/ghc/compiler/basicTypes/Var.hi-boot index 0586d90290..b33cd1f3a5 100644 --- a/ghc/compiler/basicTypes/Var.hi-boot +++ b/ghc/compiler/basicTypes/Var.hi-boot @@ -1,8 +1,10 @@ _interface_ Var 1 _exports_ -Var Var Id ; +Var Var Id setIdName ; _declarations_ -- Used by Name 1 type Id = Var ; 1 data Var ; +1 setIdName _:_ Id -> Name.Name -> Id ;; + diff --git a/ghc/compiler/basicTypes/Var.hi-boot-5 b/ghc/compiler/basicTypes/Var.hi-boot-5 index e5c730ceec..f337d4759d 100644 --- a/ghc/compiler/basicTypes/Var.hi-boot-5 +++ b/ghc/compiler/basicTypes/Var.hi-boot-5 @@ -1,5 +1,7 @@ __interface Var 1 0 where -__export Var Var Id ; +__export Var Var Id setIdName ; -- Used by Name 1 type Id = Var; 1 data Var ; +1 setIdName :: Id -> Name.Name -> Id ; + diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b1c0b36a67..1fccb1f488 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.21 1998/12/22 18:03:27 simonm Exp $ +% $Id: CgCase.lhs,v 1.22 1999/01/27 14:51:31 simonpj Exp $ % %******************************************************** %* * @@ -546,7 +546,12 @@ Tag is held in a temporary. \begin{code} cgInlineAlts bndr (StgAlgAlts ty alts deflt) - = cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-} + = -- bind the default binder (it covers all the alternatives) + (if (isDeadBinder bndr) + then nopC + else bindNewToReg bndr node mkLFArgument) `thenC` + + cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-} False{-not poly case-} alts deflt False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) -> diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 142ee9c1fc..6bd024d70e 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -36,7 +36,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, import CostCentre ( CostCentre, CostCentreStack ) import FiniteMap ( FiniteMap ) import Id ( Id, idName ) -import Name ( Module, moduleCString, moduleString ) +import Name ( Module, moduleString ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Type ( Type ) import TyCon ( TyCon ) @@ -93,12 +93,6 @@ codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) mkAbstractCs [ cost_centre_stuff, module_code ] where - ----------------- - grp_name = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> _PK_ (moduleString mod_name) -- default: module name - - ----------------- mkCcRegister ccs cc_stacks import_names = let register_ccs = mkAbstractCs (map mk_register ccs) @@ -108,7 +102,7 @@ codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) in [ CCallProfCCMacro SLIT("START_REGISTER_CCS") - [ CLitLit (_PK_ ("_reg" ++ moduleCString mod_name)) AddrRep], + [ CLitLit (_PK_ ("_reg" ++ moduleString mod_name)) AddrRep], register_ccs, register_cc_stacks, register_imports, @@ -123,7 +117,7 @@ codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) mk_import_register import_name = CCallProfCCMacro SLIT("REGISTER_IMPORT") - [CLitLit (_PK_ ("_reg" ++ moduleCString import_name)) AddrRep] + [CLitLit (_PK_ ("_reg" ++ moduleString import_name)) AddrRep] \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index a5a7c9adec..ba81cee6a6 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -16,6 +16,7 @@ module PprCore ( #include "HsVersions.h" import CoreSyn +import CostCentre ( pprCostCentreCore ) import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id ) import Var ( isTyVar ) import IdInfo ( ppIdInfo ) @@ -89,8 +90,8 @@ pprGenericEnv = initCoreEnv (\site -> ppr) \begin{code} initCoreEnv pbdr = initPprEnv - (Just ppr) -- Constants - (Just ppr) -- Cost centres + (Just ppr) -- Constants + (Just pprCostCentreCore) -- Cost centres (Just ppr) -- tyvar occs (Just pprParendType) -- types @@ -235,8 +236,7 @@ ppr_expr pe (Let bind expr) NonRec _ _ -> SLIT("let {") ppr_expr pe (Note (SCC cc) expr) - = sep [hsep [ptext SLIT("__scc"), pSCC pe cc], - ppr_parend_expr pe expr ] + = sep [pSCC pe cc, ppr_expr pe expr] #ifdef DEBUG ppr_expr pe (Note (Coerce to_ty from_ty) expr) @@ -272,7 +272,7 @@ ppr_case_pat pe con args where ppr_bndr = pBndr pe CaseBind -ppr_arg pe (Type ty) = ptext SLIT("__a") <+> pTy pe ty +ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty ppr_arg pe expr = ppr_parend_expr pe expr arrow = ptext SLIT("->") @@ -289,7 +289,7 @@ pprCoreBinder LetBind binder sig = pprTypedBinder binder pragmas = ppIdInfo (idInfo binder) --- Lambda bound type variables are preceded by "__a" +-- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr = pprTypedBinder bndr -- Case bound things don't get a signature or a herald @@ -304,7 +304,7 @@ pprUntypedBinder binder | otherwise = pprIdBndr binder pprTypedBinder binder - | isTyVar binder = ptext SLIT("__a") <+> pprTyVarBndr binder + | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder) -- The space before the :: is important; it helps the lexer -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 4d1f001674..a3c5597a76 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -22,7 +22,7 @@ import DsUtils ( EquationInfo(..), import Id ( idType ) import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon, dataConSourceArity ) -import Name ( Name, mkLocalName, getOccName, isConSymOcc, getName, varOcc ) +import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc ) import Type ( Type, isUnboxedType, splitTyConApp_maybe @@ -48,6 +48,7 @@ import TysWiredIn ( nilDataCon, consDataCon, ) import Unique ( unboundKey ) import TyCon ( tyConDataCons ) +import SrcLoc ( noSrcLoc ) import UniqSet import Outputable @@ -390,7 +391,8 @@ make_row_vars used_lits (EqnInfo _ _ pats _ ) = where new_var = hash_x hash_x = mkLocalName unboundKey {- doesn't matter much -} - (varOcc SLIT("#x")) + (mkSrcVarOcc SLIT("#x")) + noSrcLoc make_row_vars_for_constructor :: EquationInfo -> [WarningPat] make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat) @@ -511,8 +513,7 @@ contructors until the [] to know taht we need to use the second case, not the second. \begin{code} - -isInfixCon con = isConSymOcc (getOccName con) +isInfixCon con = isDataSymOcc (getOccName con) is_nil (ConPatIn con []) = con == getName nilDataCon is_nil _ = False diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 5b02056867..8e43035782 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -22,7 +22,7 @@ import Name ( Module, moduleString ) import Bag ( isEmptyBag, unionBags ) import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn ) import CoreLint ( beginPass, endPass ) -import ErrUtils ( doIfSet ) +import ErrUtils ( doIfSet, pprBagOfWarnings ) import Outputable import UniqSupply ( splitUniqSupply, UniqSupply ) \end{code} @@ -41,7 +41,7 @@ deSugar :: UniqSupply -- name supply deSugar us global_val_env mod_name all_binds fo_decls = do beginPass "Desugar" -- Do desugaring - let (core_prs, ds_warns) = initDs us1 global_val_env module_and_group + let (core_prs, ds_warns1) = initDs us1 global_val_env module_and_group (dsMonoBinds opt_SccProfilingOn all_binds []) ds_binds' = [Rec core_prs] @@ -50,9 +50,11 @@ deSugar us global_val_env mod_name all_binds fo_decls = do ds_binds = fi_binds ++ ds_binds' ++ fe_binds + ds_warns = ds_warns1 `unionBags` ds_warns2 + -- Display any warnings - doIfSet (not (isEmptyBag (ds_warns `unionBags` ds_warns2))) - (printErrs (pprDsWarnings ds_warns)) + doIfSet (not (isEmptyBag ds_warns)) + (printErrs (pprBagOfWarnings ds_warns)) -- Lint result if necessary endPass "Desugar" opt_D_dump_ds ds_binds diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index d5a305a84d..1a4046d3c7 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -153,7 +153,7 @@ addAutoScc auto_scc_candidate pair@(bndr, core_expr) | auto_scc_candidate && worthSCC core_expr && (opt_AutoSccsOnAllToplevs || (isExported bndr && opt_AutoSccsOnExportedToplevs)) = getModuleAndGroupDs `thenDs` \ (mod,grp) -> - returnDs (bndr, Note (SCC (mkAutoCC bndr mod grp IsNotCafCC)) core_expr) + returnDs (bndr, Note (SCC (mkAutoCC bndr mod grp NotCafCC)) core_expr) | otherwise = returnDs pair diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 8871fb5704..c5e90f390b 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -22,11 +22,12 @@ import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( coreExprType ) import Const ( Con(..), mkMachInt ) import DataCon ( DataCon, dataConId ) -import Id ( Id, idType, idName, - mkIdVisible, mkWildId - ) +import Id ( Id, idType, idName, mkWildId, mkUserId ) import Const ( Literal(..) ) -import Name ( getOccString, NamedThing(..) ) +import Name ( mkGlobalName, nameModule, nameOccName, getOccString, + mkForeignExportOcc, + NamedThing(..), Provenance(..), ExportFlag(..) + ) import PrelVals ( realWorldPrimId ) import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME ) import Type ( splitAlgTyConApp_maybe, @@ -203,6 +204,13 @@ The function that does most of the work for 'foreign export' declarations. (see below for the boilerplate code a 'foreign export' declaration expands into.) +For each 'foreign export foo' in a module M we generate: + +* a C function 'foo', which calls +* a Haskell stub 'M.$ffoo', which calls + +the user-written Haskell function 'M.foo'. + \begin{code} dsFExport :: Id -> Type -- Type of foreign export. @@ -215,7 +223,17 @@ dsFExport :: Id , SDoc ) dsFExport i ty ext_name cconv isDyn = - newSysLocalDs helper_ty `thenDs` \ f_helper -> + getUniqueDs `thenDs` \ uniq -> + getSrcLocDs `thenDs` \ src_loc -> + let + f_helper_glob = mkUserId helper_name helper_ty + where + name = idName i + mod = nameModule name + occ = mkForeignExportOcc (nameOccName name) + prov = LocalDef src_loc Exported + helper_name = mkGlobalName uniq mod occ prov + in newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> (if isDyn then newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> @@ -268,7 +286,6 @@ dsFExport i ty ext_name cconv isDyn = ExtName fs _ -> fs Dynamic -> panic "dsFExport: Dynamic - shouldn't ever happen." - f_helper_glob = mkIdVisible mod f_helper (h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_result_ty cconv isDyn in returnDs (NonRec f_helper_glob the_body, h_stub, c_stub) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 930b851bdc..ea697b206a 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -20,7 +20,7 @@ module DsMonad ( ValueEnv, dsWarn, DsWarnings, - DsMatchContext(..), DsMatchKind(..), pprDsWarnings + DsMatchContext(..), DsMatchKind(..) ) where #include "HsVersions.h" @@ -28,7 +28,7 @@ module DsMonad ( import Bag ( emptyBag, snocBag, bagToList, Bag ) import ErrUtils ( WarnMsg, pprBagOfErrors ) import HsSyn ( OutPat ) -import Id ( mkUserLocal, mkSysLocal, setIdUnique, Id ) +import Id ( mkSysLocal, setIdUnique, Id ) import Name ( Module, Name, maybeWiredInIdName ) import Var ( TyVar, setTyVarUnique ) import VarEnv @@ -234,7 +234,4 @@ data DsMatchKind | ListCompMatch | LetMatch deriving () - -pprDsWarnings :: DsWarnings -> SDoc -pprDsWarnings warns = pprBagOfErrors warns \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index b0f58d1332..d9de19c434 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -95,34 +95,32 @@ dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where warn | length qs > maximum_output = pp_context ctx (ptext SLIT("are overlapped")) - 8 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ ptext SLIT("...")) | otherwise = pp_context ctx (ptext SLIT("are overlapped")) - 8 (\ f -> vcat $ map (ppr_eqn f kind) qs) + (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn where - warn | length pats > maximum_output - = pp_context ctx (ptext SLIT("are non-exhaustive")) - 8 (\ f -> hang (ptext SLIT("Patterns not recognized:")) - 4 (vcat (map (ppr_incomplete_pats kind) - (take maximum_output pats)) - $$ ptext SLIT("..."))) - | otherwise - = pp_context ctx (ptext SLIT("are non-exhaustive")) - 8 (\ f -> hang (ptext SLIT("Patterns not recognized:")) - 4 (vcat $ map (ppr_incomplete_pats kind) pats)) + warn = pp_context ctx (ptext SLIT("are non-exhaustive")) + (\f -> hang (ptext SLIT("Patterns not matched:")) + 4 ((vcat $ map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ dots)) + + dots | length pats > maximum_output = ptext SLIT("...") + | otherwise = empty -pp_context NoMatchContext msg ind rest_of_msg_fun - = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind (rest_of_msg_fun id)) +pp_context NoMatchContext msg rest_of_msg_fun + = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) -pp_context (DsMatchContext kind pats loc) msg ind rest_of_msg_fun +pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun = case pp_match kind pats of (ppr_match, pref) -> - addErrLocHdrLine loc message (nest ind (rest_of_msg_fun pref)) + addErrLocHdrLine loc message (nest 8 (rest_of_msg_fun pref)) where message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' where diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 372f7ea23f..a9a114d4a3 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -20,7 +20,6 @@ import PprCore () -- Instances for Outputable --others: import Id ( Id ) -import Name ( OccName, NamedThing(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Outputable import Bag @@ -63,7 +62,7 @@ nullBinds (MonoBind b _ _) = nullMonoBinds b \end{code} \begin{code} -instance (Outputable pat, NamedThing id, Outputable id) => +instance (Outputable pat, Outputable id) => Outputable (HsBinds id pat) where ppr binds = ppr_binds binds @@ -166,14 +165,15 @@ andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat) => +instance (Outputable id, Outputable pat) => Outputable (MonoBinds id pat) where ppr mbind = ppr_monobind mbind +ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc ppr_monobind EmptyMonoBinds = empty ppr_monobind (AndMonoBinds binds1 binds2) - = ($$) (ppr_monobind binds1) (ppr_monobind binds2) + = ppr_monobind binds1 $$ ppr_monobind binds2 ppr_monobind (PatMonoBind pat grhss locn) = sep [ppr pat, nest 4 (pprGRHSs False grhss)] @@ -189,11 +189,12 @@ ppr_monobind (CoreMonoBind name expr) = sep [ppr name <+> equals, nest 4 (ppr expr)] ppr_monobind (AbsBinds tyvars dictvars exports val_binds) - = ($$) (sep [ptext SLIT("AbsBinds"), - brackets (interpp'SP tyvars), - brackets (interpp'SP dictvars), - brackets (interpp'SP exports)]) - (nest 4 (ppr val_binds)) + = sep [ptext SLIT("AbsBinds"), + brackets (interpp'SP tyvars), + brackets (interpp'SP dictvars), + brackets (interpp'SP exports)] + $$ + nest 4 (ppr val_binds) \end{code} %************************************************************************ @@ -260,7 +261,7 @@ nonFixitySigs sigs = filter not_fix sigs \end{code} \begin{code} -instance (NamedThing name, Outputable name) => Outputable (Sig name) where +instance (Outputable name) => Outputable (Sig name) where ppr sig = ppr_sig sig instance Outputable name => Outputable (FixitySig name) where @@ -271,7 +272,7 @@ ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] ppr_sig (ClassOpSig var _ ty _) - = sep [ppr (getOccName var) <+> dcolon, nest 4 (ppr ty)] + = sep [ppr var <+> dcolon, nest 4 (ppr ty)] ppr_sig (SpecSig var ty using _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 2811ee6ca5..d5f0b1b504 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -29,7 +29,6 @@ import Demand ( Demand ) import CallConv ( CallConv, pprCallConv ) -- others: -import Name ( NamedThing ) import Outputable import SrcLoc ( SrcLoc ) import Util @@ -72,7 +71,7 @@ data HsDecl name pat \begin{code} #ifdef DEBUG -hsDeclName :: (NamedThing name, Outputable name, Outputable pat) +hsDeclName :: (Outputable name, Outputable pat) => HsDecl name pat -> name #endif hsDeclName (TyClD decl) = tyClDeclName decl @@ -92,7 +91,7 @@ tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _) = name \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) +instance (Outputable name, Outputable pat) => Outputable (HsDecl name pat) where ppr (TyClD dcl) = ppr dcl @@ -107,11 +106,11 @@ instance (NamedThing name, Outputable name, Outputable pat) #ifdef DEBUG -- hsDeclName needs more context when DEBUG is on -instance (NamedThing name, Outputable name, Outputable pat, Eq name) +instance (Outputable name, Outputable pat, Eq name) => Eq (HsDecl name pat) where d1 == d2 = hsDeclName d1 == hsDeclName d2 -instance (NamedThing name, Outputable name, Outputable pat, Ord name) +instance (Outputable name, Outputable pat, Ord name) => Ord (HsDecl name pat) where d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2 #else @@ -183,7 +182,7 @@ isClassDecl other = False \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) +instance (Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where ppr (TySynonym tycon tyvars mono_ty src_loc) @@ -241,7 +240,7 @@ data SpecDataSig name (HsType name) SrcLoc -instance (NamedThing name, Outputable name) +instance (Outputable name) => Outputable (SpecDataSig name) where ppr (SpecDataSig tycon ty _) @@ -286,7 +285,7 @@ data BangType name \end{code} \begin{code} -instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where +instance (Outputable name) => Outputable (ConDecl name) where ppr (ConDecl con tvs cxt con_details loc) = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details] @@ -338,7 +337,7 @@ data InstDecl name pat \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) +instance (Outputable name, Outputable pat) => Outputable (InstDecl name pat) where ppr (InstDecl inst_ty binds uprags dfun_name src_loc) @@ -367,7 +366,7 @@ data DefaultDecl name = DefaultDecl [HsType name] SrcLoc -instance (NamedThing name, Outputable name) +instance (Outputable name) => Outputable (DefaultDecl name) where ppr (DefaultDecl tys src_loc) @@ -390,7 +389,7 @@ data ForeignDecl name = CallConv SrcLoc -instance (NamedThing name, Outputable name) +instance (Outputable name) => Outputable (ForeignDecl name) where ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc) @@ -440,7 +439,7 @@ data IfaceSig name [HsIdInfo name] SrcLoc -instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where +instance (Outputable name) => Outputable (IfaceSig name) where ppr (IfaceSig var ty _ _) = hang (hsep [ppr var, dcolon]) 4 (ppr ty) diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot index dd003096b7..a5e4c425b8 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot @@ -3,5 +3,5 @@ _exports_ HsExpr HsExpr pprExpr; _declarations_ 1 data HsExpr i p; -1 pprExpr _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;; +1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;; diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index d1ba9015f9..b7f88afacc 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -17,7 +17,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..) ) import HsTypes ( HsType ) -- others: -import Name ( Name, NamedThing(..), isSymOcc ) +import Name ( Name, isLexId ) import Outputable import PprType ( pprType, pprParendType ) import Type ( Type ) @@ -184,13 +184,13 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A \end{verbatim} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat) => +instance (Outputable id, Outputable pat) => Outputable (HsExpr id pat) where ppr expr = pprExpr expr \end{code} \begin{code} -pprExpr :: (NamedThing id, Outputable id, Outputable pat) +pprExpr :: (Outputable id, Outputable pat) => HsExpr id pat -> SDoc pprExpr e = pprDeeper (ppr_expr e) @@ -223,10 +223,15 @@ ppr_expr (OpApp e1 op fixity e2) = hang (pprExpr op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, hsep [pp_v, pp_e2]] + = sep [pp_e1, hsep [pp_v_op, pp_e2]] where - pp_v | isSymOcc (getOccName v) = ppr v - | otherwise = char '`' <> ppr v <> char '`' + pp_v = ppr v + pp_v_op | isLexId (_PK_ (showSDoc pp_v)) = char '`' <> pp_v <> char '`' + | otherwise = pp_v + -- Put it in backquotes if it's not an operator already + -- We use (showSDoc pp_v), rather than isSymOcc (getOccName v) simply so + -- that we don't need NamedThing in the context of all these funcions. + -- Gruesome, but simple. ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e @@ -348,7 +353,7 @@ ppr_expr (DictApp expr dnames) Parenthesize unless very simple: \begin{code} -pprParendExpr :: (NamedThing id, Outputable id, Outputable pat) +pprParendExpr :: (Outputable id, Outputable pat) => HsExpr id pat -> SDoc pprParendExpr expr @@ -375,7 +380,7 @@ pprParendExpr expr %************************************************************************ \begin{code} -pp_rbinds :: (NamedThing id, Outputable id, Outputable pat) +pp_rbinds :: (Outputable id, Outputable pat) => SDoc -> HsRecordBinds id pat -> SDoc @@ -435,7 +440,7 @@ data Stmt id pat \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat) => +instance (Outputable id, Outputable pat) => Outputable (Stmt id pat) where ppr stmt = pprStmt stmt @@ -470,7 +475,7 @@ data ArithSeqInfo id pat \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat) => +instance (Outputable id, Outputable pat) => Outputable (ArithSeqInfo id pat) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 84dcfce862..ff1a095e83 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -8,8 +8,7 @@ module HsImpExp where #include "HsVersions.h" -import BasicTypes ( IfaceFlavour(..) ) -import Name ( Module, NamedThing, pprModule ) +import OccName ( Module, pprModule, moduleIfaceFlavour, bootFlavour ) import Outputable import SrcLoc ( SrcLoc ) \end{code} @@ -25,22 +24,20 @@ One per \tr{import} declaration in a module. data ImportDecl name = ImportDecl Module -- module name Bool -- True => qualified - IfaceFlavour -- True => source imported module - -- (current interpretation: ignore ufolding info) (Maybe Module) -- as Module (Maybe (Bool, [IE name])) -- (True => hiding, names) SrcLoc \end{code} \begin{code} -instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where - ppr (ImportDecl mod qual as_source as spec _) - = hang (hsep [ptext SLIT("import"), pp_src as_source, +instance (Outputable name) => Outputable (ImportDecl name) where + ppr (ImportDecl mod qual as spec _) + = hang (hsep [ptext SLIT("import"), pp_src, pp_qual qual, pprModule mod, pp_as as]) 4 (pp_spec spec) where - pp_src HiFile = empty - pp_src HiBootFile = ptext SLIT("{-# SOURCE #-}") + pp_src | bootFlavour (moduleIfaceFlavour mod) = ptext SLIT("{-# SOURCE #-}") + | otherwise = empty pp_qual False = empty pp_qual True = ptext SLIT("qualified") @@ -79,7 +76,7 @@ ieName (IEThingAll n) = n \end{code} \begin{code} -instance (NamedThing name, Outputable name) => Outputable (IE name) where +instance (Outputable name) => Outputable (IE name) where ppr (IEVar var) = ppr var ppr (IEThingAbs thing) = ppr thing ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] diff --git a/ghc/compiler/hsSyn/HsMatches.hi-boot b/ghc/compiler/hsSyn/HsMatches.hi-boot index b470ced76d..ded23ff296 100644 --- a/ghc/compiler/hsSyn/HsMatches.hi-boot +++ b/ghc/compiler/hsSyn/HsMatches.hi-boot @@ -4,6 +4,6 @@ HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ; _declarations_ 1 data Match a b ; 1 data GRHSs a b ; -1 pprGRHSs _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ;; -1 pprMatch _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match i p -> Outputable.SDoc ;; -1 pprMatches _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match i p] -> Outputable.SDoc ;; +1 pprGRHSs _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ;; +1 pprMatch _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match i p -> Outputable.SDoc ;; +1 pprMatches _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match i p] -> Outputable.SDoc ;; diff --git a/ghc/compiler/hsSyn/HsMatches.hi-boot-5 b/ghc/compiler/hsSyn/HsMatches.hi-boot-5 index 37d55ed766..4ef667ff2a 100644 --- a/ghc/compiler/hsSyn/HsMatches.hi-boot-5 +++ b/ghc/compiler/hsSyn/HsMatches.hi-boot-5 @@ -2,6 +2,6 @@ __interface HsMatches 1 0 where __export HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ; 1 data Match a b ; 1 data GRHSs a b ; -1 pprGRHSs :: __forall [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ; -1 pprMatch :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match _i _p -> Outputable.SDoc ; -1 pprMatches :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _i _p] -> Outputable.SDoc ; +1 pprGRHSs :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ; +1 pprMatch :: __forall [_i _p] {Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match _i _p -> Outputable.SDoc ; +1 pprMatches :: __forall [_i _p] {Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _i _p] -> Outputable.SDoc ; diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 7fe648d25e..94409c43f7 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -19,7 +19,6 @@ import HsTypes ( HsTyVar, HsType ) import Type ( Type ) import SrcLoc ( SrcLoc ) import Outputable -import Name ( NamedThing ) \end{code} %************************************************************************ @@ -90,12 +89,12 @@ getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (NamedThing id, Outputable id, Outputable pat) +pprMatches :: (Outputable id, Outputable pat) => (Bool, SDoc) -> [Match id pat] -> SDoc pprMatches print_info matches = vcat (map (pprMatch print_info) matches) -pprMatch :: (NamedThing id, Outputable id, Outputable pat) +pprMatch :: (Outputable id, Outputable pat) => (Bool, SDoc) -> Match id pat -> SDoc pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss) = maybe_name <+> sep [sep (map ppr pats), @@ -109,7 +108,7 @@ pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss) Nothing -> empty -pprGRHSs :: (NamedThing id, Outputable id, Outputable pat) +pprGRHSs :: (Outputable id, Outputable pat) => Bool -> GRHSs id pat -> SDoc pprGRHSs is_case (GRHSs grhss binds maybe_ty) = vcat (map (pprGRHS is_case) grhss) @@ -118,7 +117,7 @@ pprGRHSs is_case (GRHSs grhss binds maybe_ty) else text "where" $$ nest 4 (pprDeeper (ppr binds))) -pprGRHS :: (NamedThing id, Outputable id, Outputable pat) +pprGRHS :: (Outputable id, Outputable pat) => Bool -> GRHS id pat -> SDoc pprGRHS is_case (GRHS [ExprStmt expr _] locn) diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index cbd0e0d767..b83d5022a2 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -26,7 +26,7 @@ import BasicTypes ( Fixity ) -- others: import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) -import Name ( isConSymOcc, getOccName, NamedThing ) +import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) @@ -201,7 +201,7 @@ pprOutPat (ConPat name ty tyvars dicts pats) parens $ case pats of [p1,p2] - | userStyle sty && isConSymOcc (getOccName name) -> + | userStyle sty && isDataSymOcc (getOccName name) -> hsep [ppr p1, ppr name, ppr p2] _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index fb63e87008..fb656a2002 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -22,7 +22,7 @@ module HsSyn ( module HsMatches, module HsPat, module HsTypes, - Fixity, NewOrData, IfaceFlavour, + Fixity, NewOrData, collectTopBinders, collectMonoBinders ) where @@ -39,13 +39,13 @@ import HsMatches import HsPat import HsTypes import HsCore -import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour ) +import BasicTypes ( Fixity, Version, NewOrData ) -- others: import Outputable import SrcLoc ( SrcLoc ) import Bag -import Name ( Module, NamedThing, pprModule ) +import OccName ( Module, pprModule ) \end{code} All we actually declare here is the top-level structure for a module. @@ -66,7 +66,7 @@ data HsModule name pat \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) +instance (Outputable name, Outputable pat) => Outputable (HsModule name pat) where ppr (HsModule name iface_version exports imports diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index b461e4ba4b..39bdd00c00 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -47,16 +47,15 @@ addErrLocHdrLine locn hdr rest_of_err_msg addShortWarnLocLine locn rest_of_err_msg = ( locn - , hang (ppr locn <> ptext SLIT(": Warning:")) - 4 rest_of_err_msg + , hang (ppr locn <> colon) + 4 (ptext SLIT("Warning:") <+> rest_of_err_msg) ) dontAddErrLoc :: String -> Message -> ErrMsg dontAddErrLoc title rest_of_err_msg | null title = (noSrcLoc, rest_of_err_msg) | otherwise = - ( noSrcLoc, hang (hcat [text title, char ':']) - 4 rest_of_err_msg ) + ( noSrcLoc, hang (text title <> colon) 4 rest_of_err_msg ) pprBagOfErrors :: Bag ErrMsg -> SDoc pprBagOfErrors bag_of_errors diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 5e209aae7e..a2b89c5df2 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -372,7 +372,7 @@ ppSourceStats short (HsModule name version exports imports decls src_loc) sig_info (InlineSig _ _) = (0,0,0,1) sig_info _ = (0,0,0,0) - import_info (ImportDecl _ qual _ as spec _) + import_info (ImportDecl _ qual as spec _) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) qual_info False = 0 qual_info True = 1 diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index dbc8f08c97..b7924598ea 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -16,12 +16,11 @@ import IO ( Handle, hPutStr, openFile, hClose, hPutStrLn, IOMode(..) ) import HsSyn -import RdrHsSyn ( RdrName(..) ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..), +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), StrictnessMark(..) ) import RnMonad -import RnEnv ( availName, ifaceFlavour ) +import RnEnv ( availName ) import TcInstUtil ( InstInfo(..) ) import WorkWrap ( getWorkerIdAndCons ) @@ -43,10 +42,11 @@ import CoreSyn ( CoreExpr, CoreBind, Bind(..) ) import CoreUtils ( exprSomeFreeVars ) import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding, okToUnfoldInHiFile ) -import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, - OccName, pprOccName, pprModule, isExported, moduleString, +import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule, + isExported, Name, NamedThing(..) ) +import OccName ( OccName, pprOccName, moduleString, pprModule, pprModuleBoot ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons ) @@ -146,9 +146,9 @@ ifaceDecls (Just hdl) ifaceImports if_hdl import_usages = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - upp_uses (m, hif, mv, whats_imported) + upp_uses (m, mv, whats_imported) = ptext SLIT("import ") <> - hsep [pprModule m, pp_hif hif, int mv, dcolon, + hsep [pprModule m, pprModuleBoot m, int mv, dcolon, upp_import_versions whats_imported ] <> semi @@ -176,7 +176,6 @@ ifaceExports if_hdl avails export_fm :: FiniteMap Module [AvailInfo] export_fm = foldr insert emptyFM avails - insert NotAvailable efm = efm insert avail efm = addToFM_C (++) efm mod [avail] where mod = nameModule (availName avail) @@ -185,15 +184,11 @@ ifaceExports if_hdl avails do_one_module :: (Module, [AvailInfo]) -> SDoc do_one_module (mod_name, avails@(avail1:_)) = ptext SLIT("__export ") <> - hsep [pp_hif (ifaceFlavour (availName avail1)), + hsep [pprModuleBoot (nameModule (availName avail1)), pprModule mod_name, hsep (map upp_avail (sortLt lt_avail avails)) ] <> semi --- The "!" indicates that the exported things came from a hi-boot interface -pp_hif HiFile = empty -pp_hif HiBootFile = char '!' - ifaceFixities if_hdl [] = return () ifaceFixities if_hdl fixities = hPutCol if_hdl upp_fixity fixities @@ -561,7 +556,6 @@ When printing export lists, we print like this: \begin{code} upp_avail :: AvailInfo -> SDoc -upp_avail NotAvailable = empty 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'] @@ -600,13 +594,13 @@ lt_avail :: AvailInfo -> AvailInfo -> Bool a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 lt_name :: Name -> Name -> Bool -n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2 +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 +lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2 sort_versions vs = sortLt lt_vers vs diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 3c322f2ec2..5530035f1d 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -31,7 +31,7 @@ thenUgn x y stuff y z stuff initUgn :: UgnM a -> IO a -initUgn action = action (SLIT(""),mkModule "",noSrcLoc) +initUgn action = action (SLIT(""),mkSrcModule "",noSrcLoc) ioToUgnM :: IO a -> UgnM a ioToUgnM x stuff = x diff --git a/ghc/compiler/parser/id.c b/ghc/compiler/parser/id.c index 0ee41f8b23..a8dd95bdaa 100644 --- a/ghc/compiler/parser/id.c +++ b/ghc/compiler/parser/id.c @@ -295,7 +295,7 @@ creategid(i) { switch(i) { case ARROWGID: - return(mkgid(i,install_literal("->"))); + return(mkgid(i,install_literal("(->)"))); case NILGID: return(mkgid(i,install_literal("[]"))); case UNITGID: diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 788ad255db..28c1948a3c 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -79,12 +79,13 @@ import TysPrim -- TYPES import TysWiredIn -- others: -import RdrHsSyn ( RdrName(..), varQual, tcQual, qual ) -import BasicTypes ( IfaceFlavour ) +import RdrName ( RdrName, mkPreludeQual ) import Var ( varUnique, Id ) -import Name ( Name, OccName, Provenance(..), - getName, mkGlobalName, modAndOcc +import Name ( Name, OccName, Provenance(..), + NameSpace, tcName, clsName, varName, dataName, + getName, mkGlobalName, nameRdrName, systemProvenance ) +import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual ) import Class ( Class, classKey ) import TyCon ( tyConDataCons, TyCon ) import Type ( funTyCon ) @@ -257,26 +258,26 @@ thinAirIdNames = map mkKnownKeyGlobal [ -- Needed for converting literals to Integers (used in tidyCoreExpr) - (varQual (pREL_BASE, SLIT("int2Integer")), int2IntegerIdKey) - , (varQual (pREL_BASE, SLIT("addr2Integer")), addr2IntegerIdKey) + (varQual pREL_BASE SLIT("int2Integer"), int2IntegerIdKey) + , (varQual pREL_BASE SLIT("addr2Integer"), addr2IntegerIdKey) -- OK, this is Will's idea: we should have magic values for Integers 0, -- +1, +2, and -1 (go ahead, fire me): - , (varQual (pREL_BASE, SLIT("integer_0")), integerZeroIdKey) - , (varQual (pREL_BASE, SLIT("integer_1")), integerPlusOneIdKey) - , (varQual (pREL_BASE, SLIT("integer_2")), integerPlusTwoIdKey) - , (varQual (pREL_BASE, SLIT("integer_m1")), integerMinusOneIdKey) + , (varQual pREL_BASE SLIT("integer_0"), integerZeroIdKey) + , (varQual pREL_BASE SLIT("integer_1"), integerPlusOneIdKey) + , (varQual pREL_BASE SLIT("integer_2"), integerPlusTwoIdKey) + , (varQual pREL_BASE SLIT("integer_m1"), integerMinusOneIdKey) -- String literals - , (varQual (pREL_PACK, SLIT("packCString#")), packCStringIdKey) - , (varQual (pREL_PACK, SLIT("unpackCString#")), unpackCStringIdKey) - , (varQual (pREL_PACK, SLIT("unpackNBytes#")), unpackCString2IdKey) - , (varQual (pREL_PACK, SLIT("unpackAppendCString#")), unpackCStringAppendIdKey) - , (varQual (pREL_PACK, SLIT("unpackFoldrCString#")), unpackCStringFoldrIdKey) + , (varQual pREL_PACK SLIT("packCString#"), packCStringIdKey) + , (varQual pREL_PACK SLIT("unpackCString#"), unpackCStringIdKey) + , (varQual pREL_PACK SLIT("unpackNBytes#"), unpackCString2IdKey) + , (varQual pREL_PACK SLIT("unpackAppendCString#"), unpackCStringAppendIdKey) + , (varQual pREL_PACK SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey) -- Folds; introduced by desugaring list comprehensions - , (varQual (pREL_BASE, SLIT("foldr")), foldrIdKey) + , (varQual pREL_BASE SLIT("foldr"), foldrIdKey) ] thinAirModules = [pREL_PACK] -- See notes with RnIfaces.findAndReadIface @@ -337,8 +338,9 @@ Ids, Synonyms, Classes and ClassOps with builtin keys. \begin{code} mkKnownKeyGlobal :: (RdrName, Unique) -> Name -mkKnownKeyGlobal (Qual mod occ hif, uniq) - = mkGlobalName uniq mod occ NoProvenance +mkKnownKeyGlobal (rdr_name, uniq) + = mkGlobalName uniq (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + systemProvenance ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey) main_NAME = mkKnownKeyGlobal (main_RDR, mainKey) @@ -441,116 +443,116 @@ These RdrNames are not really "built in", but some parts of the compiler to write them all down in one place. \begin{code} -prelude_primop op = qual (modAndOcc (mkPrimitiveId op)) - -main_RDR = varQual (mAIN, SLIT("main")) -otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise")) - -intTyCon_RDR = qual (modAndOcc intTyCon) -ioTyCon_RDR = tcQual (pREL_IO_BASE, SLIT("IO")) -ioDataCon_RDR = varQual (pREL_IO_BASE, SLIT("IO")) -bindIO_RDR = varQual (pREL_IO_BASE, SLIT("bindIO")) - -orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering")) -rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational")) -ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio")) -ratioDataCon_RDR = varQual (pREL_NUM, SLIT(":%")) - -byteArrayTyCon_RDR = tcQual (pREL_ARR, SLIT("ByteArray")) -mutableByteArrayTyCon_RDR = tcQual (pREL_ARR, SLIT("MutableByteArray")) - -foreignObjTyCon_RDR = tcQual (pREL_IO_BASE, SLIT("ForeignObj")) -stablePtrTyCon_RDR = tcQual (pREL_STABLE, SLIT("StablePtr")) -deRefStablePtr_RDR = varQual (pREL_STABLE, SLIT("deRefStablePtr")) -makeStablePtr_RDR = varQual (pREL_STABLE, SLIT("makeStablePtr")) - -eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq")) -ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord")) -boundedClass_RDR = tcQual (pREL_BASE, SLIT("Bounded")) -numClass_RDR = tcQual (pREL_BASE, SLIT("Num")) -enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum")) -monadClass_RDR = tcQual (pREL_BASE, SLIT("Monad")) -monadPlusClass_RDR = tcQual (pREL_BASE, SLIT("MonadPlus")) -functorClass_RDR = tcQual (pREL_BASE, SLIT("Functor")) -showClass_RDR = tcQual (pREL_BASE, SLIT("Show")) -realClass_RDR = tcQual (pREL_NUM, SLIT("Real")) -integralClass_RDR = tcQual (pREL_NUM, SLIT("Integral")) -fractionalClass_RDR = tcQual (pREL_NUM, SLIT("Fractional")) -floatingClass_RDR = tcQual (pREL_NUM, SLIT("Floating")) -realFracClass_RDR = tcQual (pREL_NUM, SLIT("RealFrac")) -realFloatClass_RDR = tcQual (pREL_NUM, SLIT("RealFloat")) -readClass_RDR = tcQual (pREL_READ, SLIT("Read")) -ixClass_RDR = tcQual (iX, SLIT("Ix")) -ccallableClass_RDR = tcQual (pREL_GHC, SLIT("CCallable")) -creturnableClass_RDR = tcQual (pREL_GHC, SLIT("CReturnable")) - -fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt")) -fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger")) -minus_RDR = varQual (pREL_BASE, SLIT("-")) -succ_RDR = varQual (pREL_BASE, SLIT("succ")) -pred_RDR = varQual (pREL_BASE, SLIT("pred")) -toEnum_RDR = varQual (pREL_BASE, SLIT("toEnum")) -fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) -enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) -enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) -enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen")) -enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) - -thenM_RDR = varQual (pREL_BASE, SLIT(">>=")) -returnM_RDR = varQual (pREL_BASE, SLIT("return")) -failM_RDR = varQual (pREL_BASE, SLIT("fail")) - -fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational")) -negate_RDR = varQual (pREL_BASE, SLIT("negate")) -eq_RDR = varQual (pREL_BASE, SLIT("==")) -ne_RDR = varQual (pREL_BASE, SLIT("/=")) -le_RDR = varQual (pREL_BASE, SLIT("<=")) -lt_RDR = varQual (pREL_BASE, SLIT("<")) -ge_RDR = varQual (pREL_BASE, SLIT(">=")) -gt_RDR = varQual (pREL_BASE, SLIT(">")) -ltTag_RDR = varQual (pREL_BASE, SLIT("LT")) -eqTag_RDR = varQual (pREL_BASE, SLIT("EQ")) -gtTag_RDR = varQual (pREL_BASE, SLIT("GT")) -max_RDR = varQual (pREL_BASE, SLIT("max")) -min_RDR = varQual (pREL_BASE, SLIT("min")) -compare_RDR = varQual (pREL_BASE, SLIT("compare")) -minBound_RDR = varQual (pREL_BASE, SLIT("minBound")) -maxBound_RDR = varQual (pREL_BASE, SLIT("maxBound")) -false_RDR = varQual (pREL_BASE, SLIT("False")) -true_RDR = varQual (pREL_BASE, SLIT("True")) -and_RDR = varQual (pREL_BASE, SLIT("&&")) -not_RDR = varQual (pREL_BASE, SLIT("not")) -compose_RDR = varQual (pREL_BASE, SLIT(".")) -append_RDR = varQual (pREL_BASE, SLIT("++")) -map_RDR = varQual (pREL_BASE, SLIT("map")) -concat_RDR = varQual (pREL_LIST, SLIT("concat")) -filter_RDR = varQual (pREL_LIST, SLIT("filter")) -zip_RDR = varQual (pREL_LIST, SLIT("zip")) - -showList___RDR = varQual (pREL_BASE, SLIT("showList__")) -showsPrec_RDR = varQual (pREL_BASE, SLIT("showsPrec")) -showList_RDR = varQual (pREL_BASE, SLIT("showList")) -showSpace_RDR = varQual (pREL_BASE, SLIT("showSpace")) -showString_RDR = varQual (pREL_BASE, SLIT("showString")) -showParen_RDR = varQual (pREL_BASE, SLIT("showParen")) - -range_RDR = varQual (iX, SLIT("range")) -index_RDR = varQual (iX, SLIT("index")) -inRange_RDR = varQual (iX, SLIT("inRange")) - -readsPrec_RDR = varQual (pREL_READ, SLIT("readsPrec")) -readList_RDR = varQual (pREL_READ, SLIT("readList")) -readParen_RDR = varQual (pREL_READ, SLIT("readParen")) -lex_RDR = varQual (pREL_READ, SLIT("lex")) -readList___RDR = varQual (pREL_READ, SLIT("readList__")) - -plus_RDR = varQual (pREL_BASE, SLIT("+")) -times_RDR = varQual (pREL_BASE, SLIT("*")) -mkInt_RDR = varQual (pREL_BASE, SLIT("I#")) - -error_RDR = varQual (pREL_ERR, SLIT("error")) -assert_RDR = varQual (pREL_GHC, SLIT("assert")) -assertErr_RDR = varQual (pREL_ERR, SLIT("assertError")) +prelude_primop op = nameRdrName (getName (mkPrimitiveId op)) + +main_RDR = varQual mAIN SLIT("main") +otherwiseId_RDR = varQual pREL_BASE SLIT("otherwise") + +intTyCon_RDR = nameRdrName (getName intTyCon) +ioTyCon_RDR = tcQual pREL_IO_BASE SLIT("IO") +ioDataCon_RDR = dataQual pREL_IO_BASE SLIT("IO") +bindIO_RDR = varQual pREL_IO_BASE SLIT("bindIO") + +orderingTyCon_RDR = tcQual pREL_BASE SLIT("Ordering") +rationalTyCon_RDR = tcQual pREL_NUM SLIT("Rational") +ratioTyCon_RDR = tcQual pREL_NUM SLIT("Ratio") +ratioDataCon_RDR = dataQual pREL_NUM SLIT(":%") + +byteArrayTyCon_RDR = tcQual pREL_ARR SLIT("ByteArray") +mutableByteArrayTyCon_RDR = tcQual pREL_ARR SLIT("MutableByteArray") + +foreignObjTyCon_RDR = tcQual pREL_IO_BASE SLIT("ForeignObj") +stablePtrTyCon_RDR = tcQual pREL_FOREIGN SLIT("StablePtr") +deRefStablePtr_RDR = varQual pREL_FOREIGN SLIT("deRefStablePtr") +makeStablePtr_RDR = varQual pREL_FOREIGN SLIT("makeStablePtr") + +eqClass_RDR = clsQual pREL_BASE SLIT("Eq") +ordClass_RDR = clsQual pREL_BASE SLIT("Ord") +boundedClass_RDR = clsQual pREL_BASE SLIT("Bounded") +numClass_RDR = clsQual pREL_BASE SLIT("Num") +enumClass_RDR = clsQual pREL_BASE SLIT("Enum") +monadClass_RDR = clsQual pREL_BASE SLIT("Monad") +monadPlusClass_RDR = clsQual pREL_BASE SLIT("MonadPlus") +functorClass_RDR = clsQual pREL_BASE SLIT("Functor") +showClass_RDR = clsQual pREL_BASE SLIT("Show") +realClass_RDR = clsQual pREL_NUM SLIT("Real") +integralClass_RDR = clsQual pREL_NUM SLIT("Integral") +fractionalClass_RDR = clsQual pREL_NUM SLIT("Fractional") +floatingClass_RDR = clsQual pREL_NUM SLIT("Floating") +realFracClass_RDR = clsQual pREL_NUM SLIT("RealFrac") +realFloatClass_RDR = clsQual pREL_NUM SLIT("RealFloat") +readClass_RDR = clsQual pREL_READ SLIT("Read") +ixClass_RDR = clsQual iX SLIT("Ix") +ccallableClass_RDR = clsQual pREL_GHC SLIT("CCallable") +creturnableClass_RDR = clsQual pREL_GHC SLIT("CReturnable") + +fromInt_RDR = varQual pREL_BASE SLIT("fromInt") +fromInteger_RDR = varQual pREL_BASE SLIT("fromInteger") +minus_RDR = varQual pREL_BASE SLIT("-") +succ_RDR = varQual pREL_BASE SLIT("succ") +pred_RDR = varQual pREL_BASE SLIT("pred") +toEnum_RDR = varQual pREL_BASE SLIT("toEnum") +fromEnum_RDR = varQual pREL_BASE SLIT("fromEnum") +enumFrom_RDR = varQual pREL_BASE SLIT("enumFrom") +enumFromTo_RDR = varQual pREL_BASE SLIT("enumFromTo") +enumFromThen_RDR = varQual pREL_BASE SLIT("enumFromThen") +enumFromThenTo_RDR = varQual pREL_BASE SLIT("enumFromThenTo") + +thenM_RDR = varQual pREL_BASE SLIT(">>=") +returnM_RDR = varQual pREL_BASE SLIT("return") +failM_RDR = varQual pREL_BASE SLIT("fail") + +fromRational_RDR = varQual pREL_NUM SLIT("fromRational") +negate_RDR = varQual pREL_BASE SLIT("negate") +eq_RDR = varQual pREL_BASE SLIT("==") +ne_RDR = varQual pREL_BASE SLIT("/=") +le_RDR = varQual pREL_BASE SLIT("<=") +lt_RDR = varQual pREL_BASE SLIT("<") +ge_RDR = varQual pREL_BASE SLIT(">=") +gt_RDR = varQual pREL_BASE SLIT(">") +ltTag_RDR = dataQual pREL_BASE SLIT("LT") +eqTag_RDR = dataQual pREL_BASE SLIT("EQ") +gtTag_RDR = dataQual pREL_BASE SLIT("GT") +max_RDR = varQual pREL_BASE SLIT("max") +min_RDR = varQual pREL_BASE SLIT("min") +compare_RDR = varQual pREL_BASE SLIT("compare") +minBound_RDR = varQual pREL_BASE SLIT("minBound") +maxBound_RDR = varQual pREL_BASE SLIT("maxBound") +false_RDR = dataQual pREL_BASE SLIT("False") +true_RDR = dataQual pREL_BASE SLIT("True") +and_RDR = varQual pREL_BASE SLIT("&&") +not_RDR = varQual pREL_BASE SLIT("not") +compose_RDR = varQual pREL_BASE SLIT(".") +append_RDR = varQual pREL_BASE SLIT("++") +map_RDR = varQual pREL_BASE SLIT("map") +concat_RDR = varQual mONAD SLIT("concat") +filter_RDR = varQual mONAD SLIT("filter") +zip_RDR = varQual pREL_LIST SLIT("zip") + +showList___RDR = varQual pREL_BASE SLIT("showList__") +showsPrec_RDR = varQual pREL_BASE SLIT("showsPrec") +showList_RDR = varQual pREL_BASE SLIT("showList") +showSpace_RDR = varQual pREL_BASE SLIT("showSpace") +showString_RDR = varQual pREL_BASE SLIT("showString") +showParen_RDR = varQual pREL_BASE SLIT("showParen") + +range_RDR = varQual iX SLIT("range") +index_RDR = varQual iX SLIT("index") +inRange_RDR = varQual iX SLIT("inRange") + +readsPrec_RDR = varQual pREL_READ SLIT("readsPrec") +readList_RDR = varQual pREL_READ SLIT("readList") +readParen_RDR = varQual pREL_READ SLIT("readParen") +lex_RDR = varQual pREL_READ SLIT("lex") +readList___RDR = varQual pREL_READ SLIT("readList__") + +plus_RDR = varQual pREL_BASE SLIT("+") +times_RDR = varQual pREL_BASE SLIT("*") +mkInt_RDR = dataQual pREL_BASE SLIT("I#") + +error_RDR = varQual pREL_ERR SLIT("error") +assert_RDR = varQual pREL_GHC SLIT("assert") +assertErr_RDR = varQual pREL_ERR SLIT("assertError") eqH_Char_RDR = prelude_primop CharEqOp ltH_Char_RDR = prelude_primop CharLtOp @@ -571,10 +573,12 @@ minusH_RDR = prelude_primop IntSubOp \begin{code} mkTupConRdrName :: Int -> RdrName -mkTupConRdrName arity = varQual (mkTupNameStr arity) +mkTupConRdrName arity = case mkTupNameStr arity of + (mod, occ) -> dataQual mod occ mkUbxTupConRdrName :: Int -> RdrName -mkUbxTupConRdrName arity = varQual (mkUbxTupNameStr arity) +mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of + (mod, occ) -> dataQual mod occ \end{code} @@ -702,3 +706,18 @@ noDictClassKeys -- These classes are used only for type annotations; -- they are not implemented by dictionaries, ever. = 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 index 3090ef70cb..294cb5d10a 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -24,7 +24,7 @@ module PrelMods #include "HsVersions.h" -import OccName ( Module, mkModule ) +import OccName ( Module, mkSrcModule ) import Util ( nOfThem ) import Panic ( panic ) \end{code} @@ -35,35 +35,34 @@ pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ :: Module pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR :: Module pREL_FOREIGN, pREL_STABLE :: Module - -pRELUDE = mkModule "Prelude" -pREL_GHC = mkModule "PrelGHC" -- Primitive types and values -pREL_BASE = mkModule "PrelBase" -pREL_READ = mkModule "PrelRead" -pREL_NUM = mkModule "PrelNum" -pREL_LIST = mkModule "PrelList" -pREL_TUP = mkModule "PrelTup" -pREL_PACK = mkModule "PrelPack" -pREL_CONC = mkModule "PrelConc" -pREL_IO_BASE = mkModule "PrelIOBase" -pREL_ST = mkModule "PrelST" -pREL_ARR = mkModule "PrelArr" -pREL_FOREIGN = mkModule "PrelForeign" -pREL_STABLE = mkModule "PrelStable" -pREL_ADDR = mkModule "PrelAddr" -pREL_ERR = mkModule "PrelErr" - -mONAD = mkModule "Monad" -rATIO = mkModule "Ratio" -iX = mkModule "Ix" - -pREL_MAIN = mkModule "PrelMain" -mAIN = mkModule "Main" +pRELUDE = mkSrcModule "Prelude" +pREL_GHC = mkSrcModule "PrelGHC" -- Primitive types and values +pREL_BASE = mkSrcModule "PrelBase" +pREL_READ = mkSrcModule "PrelRead" +pREL_NUM = mkSrcModule "PrelNum" +pREL_LIST = mkSrcModule "PrelList" +pREL_TUP = mkSrcModule "PrelTup" +pREL_PACK = mkSrcModule "PrelPack" +pREL_CONC = mkSrcModule "PrelConc" +pREL_IO_BASE = mkSrcModule "PrelIOBase" +pREL_ST = mkSrcModule "PrelST" +pREL_ARR = mkSrcModule "PrelArr" +pREL_FOREIGN = mkSrcModule "PrelForeign" +pREL_STABLE = mkSrcModule "PrelStable" +pREL_ADDR = mkSrcModule "PrelAddr" +pREL_ERR = mkSrcModule "PrelErr" + +mONAD = mkSrcModule "Monad" +rATIO = mkSrcModule "Ratio" +iX = mkSrcModule "Ix" + +pREL_MAIN = mkSrcModule "PrelMain" +mAIN = mkSrcModule "Main" iNT, wORD :: Module -iNT = mkModule "Int" -wORD = mkModule "Word" +iNT = mkSrcModule "Int" +wORD = mkSrcModule "Word" \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 15ef850797..3ebf0f97a6 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -20,7 +20,7 @@ import TysWiredIn -- others: import CoreSyn -- quite a bit import IdInfo -- quite a bit -import Name ( mkWiredInIdName, varOcc, Module ) +import Name ( mkWiredInIdName, mkSrcVarOcc, Module ) import Type import Var ( TyVar ) import Demand ( wwStrict ) @@ -159,7 +159,7 @@ pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id pcMiscPrelId key mod str ty info = let - name = mkWiredInIdName key mod (varOcc str) imp + name = mkWiredInIdName key mod (mkSrcVarOcc str) imp imp = mkVanillaId name ty `setIdInfo` info -- the usual case... in imp diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 88297355e1..0b97710abc 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -31,10 +31,10 @@ import Demand ( Demand, wwLazy, wwPrim, wwStrict ) import Var ( TyVar ) import CallConv ( CallConv, pprCallConv ) import PprType ( pprParendType ) -import OccName ( OccName, pprOccName, varOcc ) -import TyCon ( TyCon ) -import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, - mkTyConApp, typePrimRep, +import OccName ( OccName, pprOccName, mkSrcVarOcc ) +import TyCon ( TyCon, tyConArity ) +import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys, + mkTyConTy, mkTyConApp, typePrimRep, splitAlgTyConApp, Type, isUnboxedTupleType, splitAlgTyConApp_maybe ) @@ -819,10 +819,10 @@ data PrimOpInfo [Type] Type -mkDyadic str ty = Dyadic (varOcc str) ty -mkMonadic str ty = Monadic (varOcc str) ty -mkCompare str ty = Compare (varOcc str) ty -mkGenPrimOp str tvs tys ty = GenPrimOp (varOcc str) tvs tys ty +mkDyadic str ty = Dyadic (mkSrcVarOcc str) ty +mkMonadic str ty = Monadic (mkSrcVarOcc str) ty +mkCompare str ty = Compare (mkSrcVarOcc str) ty +mkGenPrimOp str tvs tys ty = GenPrimOp (mkSrcVarOcc str) tvs tys ty \end{code} Utility bits: @@ -1244,82 +1244,51 @@ primOpInfo (ReadByteArrayOp kind) s = alphaTy; s_tv = alphaTyVar op_str = _PK_ ("read" ++ primRepString kind ++ "Array#") - relevant_type = assoc "primOpInfo{ReadByteArrayOp}" tbl kind + (tvs, prim_ty) = mkPrimTyApp betaTyVars kind state = mkStatePrimTy s - - tvs - | kind == StablePtrRep = [s_tv, betaTyVar] - | otherwise = [s_tv] in - mkGenPrimOp op_str tvs + mkGenPrimOp op_str (s_tv:tvs) [mkMutableByteArrayPrimTy s, intPrimTy, state] - (unboxedPair [state, relevant_type]) - where - tbl = [ (CharRep, charPrimTy), - (IntRep, intPrimTy), - (WordRep, wordPrimTy), - (AddrRep, addrPrimTy), - (FloatRep, floatPrimTy), - (StablePtrRep, mkStablePtrPrimTy betaTy), - (DoubleRep, doublePrimTy) ] - - -- How come there's no Word byte arrays? ADR + (unboxedPair [state, prim_ty]) primOpInfo (WriteByteArrayOp kind) = let s = alphaTy; s_tv = alphaTyVar op_str = _PK_ ("write" ++ primRepString kind ++ "Array#") - prim_ty = mkTyConApp (primRepTyCon kind) [] - - (the_prim_ty, tvs) - | kind == StablePtrRep = (mkStablePtrPrimTy betaTy, [s_tv, betaTyVar]) - | otherwise = (prim_ty, [s_tv]) - + (tvs, prim_ty) = mkPrimTyApp betaTyVars kind in - mkGenPrimOp op_str tvs - [mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s] + mkGenPrimOp op_str (s_tv:tvs) + [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s] (mkStatePrimTy s) primOpInfo (IndexByteArrayOp kind) = let op_str = _PK_ ("index" ++ primRepString kind ++ "Array#") - - (prim_tycon_args, tvs) - | kind == StablePtrRep = ([alphaTy], [alphaTyVar]) - | otherwise = ([],[]) + (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind in - mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] - (mkTyConApp (primRepTyCon kind) prim_tycon_args) + mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] prim_ty primOpInfo (IndexOffForeignObjOp kind) = let op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#") - - (prim_tycon_args, tvs) - | kind == StablePtrRep = ([alphaTy], [alphaTyVar]) - | otherwise = ([], []) + (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind in - mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] - (mkTyConApp (primRepTyCon kind) prim_tycon_args) + mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] prim_ty primOpInfo (IndexOffAddrOp kind) = let op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#") - - (prim_tycon_args, tvs) - | kind == StablePtrRep = ([alphaTy], [alphaTyVar]) - | otherwise = ([], []) + (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind in - mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy] - (mkTyConApp (primRepTyCon kind) prim_tycon_args) + mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy] prim_ty primOpInfo (WriteOffAddrOp kind) = let s = alphaTy; s_tv = alphaTyVar op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#") - prim_ty = mkTyConApp (primRepTyCon kind) [] + (tvs, prim_ty) = mkPrimTyApp betaTyVars kind in - mkGenPrimOp op_str [s_tv] + mkGenPrimOp op_str (s_tv:tvs) [addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s] (mkStatePrimTy s) @@ -2063,6 +2032,15 @@ commutableOp _ = False Utils: \begin{code} +mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type) + -- CharRep --> ([], Char#) + -- StablePtrRep --> ([a], StablePtr# a) +mkPrimTyApp tvs kind + = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs)) + where + tycon = primRepTyCon kind + forall_tvs = take (tyConArity tycon) tvs + dyadic_fun_ty ty = mkFunTys [ty, ty] ty monadic_fun_ty ty = mkFunTy ty ty compare_fun_ty ty = mkFunTys [ty, ty] boolTy diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 1bb342cc3d..6bb4f67c20 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -8,7 +8,7 @@ types and operations.'' \begin{code} module TysPrim( - alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, openAlphaTyVar, openAlphaTyVars, @@ -63,6 +63,8 @@ alphaTyVars :: [TyVar] alphaTyVars = [ mkSysTyVar u boxedTypeKind | u <- map mkAlphaTyVarUnique [2..] ] +betaTyVars = tail alphaTyVars + alphaTyVar, betaTyVar, gammaTyVar :: TyVar (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index a03554c542..bb9c055436 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -92,7 +92,7 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) -import Name ( Module, varOcc, mkWiredInTyConName, mkWiredInIdName ) +import Name ( Module, mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, dataName ) import DataCon ( DataCon, mkDataCon ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, mkAlgTyCon, mkSynTyCon, mkTupleTyCon ) @@ -152,7 +152,7 @@ pcDataCon key mod str tyvars context arg_tys tycon [ NotMarkedStrict | a <- arg_tys ] [ {- no labelled fields -} ] tyvars context [] [] arg_tys tycon id - name = mkWiredInIdName key mod (varOcc str) id + name = mkWiredInIdName key mod (mkSrcOccFS dataName str) id id = mkDataConId data_con \end{code} diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 3c076c2c86..3bed2f8749 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -5,7 +5,9 @@ \begin{code} module CostCentre ( - CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..), + CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), IsDictCC(..), + -- All abstract except to friend: ParseIface.y + CostCentreStack, noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS, noCostCentre, noCCAttached, @@ -17,18 +19,18 @@ module CostCentre ( isSccCountCostCentre, sccAbleCostCentre, ccFromThisModule, - ccMentionsId, - pprCostCentreDecl, pprCostCentreStackDecl, + pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore, cmpCostCentre -- used for removing dups in a list ) where #include "HsVersions.h" -import Var ( externallyVisibleId, Id ) -import CStrings ( stringToC ) -import Name ( Module, getOccString, moduleString, identToC, pprModule ) +import Var ( Id ) +import Name ( UserFS, EncodedFS, encodeFS, decode, + Module, getOccName, occNameFS, pprModule, moduleUserString + ) import Outputable import Util ( thenCmp ) \end{code} @@ -99,33 +101,39 @@ data CostCentre = NoCostCentre -- Having this constructor avoids having -- to use "Maybe CostCentre" all the time. - | NormalCC CcKind -- CcKind will include a cost-centre name - Module -- Name of module defining this CC. - Group -- "Group" that this CC is in. - IsDupdCC -- see below - IsCafCC -- see below - - | AllCafsCC Module -- Ditto for CAFs. - Group -- We record module and group names. + | NormalCC { + cc_name :: CcName, -- Name of the cost centre itself + cc_mod :: Module, -- Name of module defining this CC. + cc_grp :: Group, -- "Group" that this CC is in. + cc_is_dict :: IsDictCC, -- see below + cc_is_dupd :: IsDupdCC, -- see below + cc_is_caf :: IsCafCC -- see below + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_grp :: Group -- "Group" that this CC is in -- Again, one "big" CAF cc per module, where all -- CAF costs are attributed unless the user asked for -- per-individual-CAF cost attribution. + } - | AllDictsCC Module -- Ditto for dictionaries. - Group -- We record module and group names. + | AllDictsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_grp :: Group, -- "Group" that this CC is in. -- Again, one "big" DICT cc per module, where all -- DICT costs are attributed unless the user asked for -- per-individual-DICT cost attribution. - IsDupdCC -- see below + cc_is_dupd :: IsDupdCC + } + +type CcName = EncodedFS -data CcKind - = UserCC FAST_STRING -- Supplied by user: String is the cc name - | AutoCC Id -- CC -auto-magically inserted for that Id - | DictCC Id +data IsDictCC = DictCC | VanillaCC data IsDupdCC - = AnOriginalCC -- This says how the CC is *used*. Saying that - | ADupdCC -- it is ADupdCC doesn't make it a different + = OriginalCC -- This says how the CC is *used*. Saying that + | DupdCC -- it is DupdCC doesn't make it a different -- CC, just that it a sub-expression which has -- been moved ("dupd") into a different scope. -- @@ -134,14 +142,12 @@ data IsDupdCC -- "original" one. -- -- In the papers, it's called "SCCsub", - -- i.e. SCCsub CC == SCC ADupdCC, + -- i.e. SCCsub CC == SCC DupdCC, -- but we are trying to avoid confusion between -- "subd" and "subsumed". So we call the former -- "dupd". -data IsCafCC - = IsCafCC - | IsNotCafCC +data IsCafCC = CafCC | NotCafCC \end{code} WILL: Would there be any merit to recording ``I am now using a @@ -191,61 +197,64 @@ currentOrSubsumedCCS _ = False Building cost centres \begin{code} -mkUserCC :: FAST_STRING -> Module -> Group -> CostCentre +mkUserCC :: UserFS -> Module -> Group -> CostCentre mkUserCC cc_name module_name group_name - = NormalCC (UserCC cc_name) module_name group_name - AnOriginalCC IsNotCafCC{-might be changed-} + = NormalCC { cc_name = encodeFS cc_name, + cc_mod = module_name, cc_grp = group_name, + cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-} + } mkDictCC, mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre mkDictCC id module_name group_name is_caf - = NormalCC (DictCC id) module_name group_name - AnOriginalCC is_caf + = NormalCC { cc_name = occNameFS (getOccName id), + cc_mod = module_name, cc_grp = group_name, + cc_is_dict = DictCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf + } mkAutoCC id module_name group_name is_caf - = NormalCC (AutoCC id) module_name group_name - AnOriginalCC is_caf + = NormalCC { cc_name = occNameFS (getOccName id), + cc_mod = module_name, cc_grp = group_name, + cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf + } -mkAllCafsCC m g = AllCafsCC m g -mkAllDictsCC m g is_dupd - = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) +mkAllCafsCC m g = AllCafsCC { cc_mod = m, cc_grp = g } +mkAllDictsCC m g is_dupd = AllDictsCC { cc_mod = m, cc_grp = g, + cc_is_dupd = if is_dupd then DupdCC else OriginalCC } mkSingletonCCS :: CostCentre -> CostCentreStack mkSingletonCCS cc = SingletonCCS cc cafifyCC, dupifyCC :: CostCentre -> CostCentre -cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ??? -cafifyCC (NormalCC kind m g is_dupd is_caf) - = ASSERT(not_a_calf_already is_caf) - NormalCC kind m g is_dupd IsCafCC +cafifyCC cc@(AllDictsCC {}) = cc +cafifyCC cc@(NormalCC {cc_is_caf = is_caf}) + = ASSERT(not_a_caf_already is_caf) + cc {cc_is_caf = CafCC} where - not_a_calf_already IsCafCC = False - not_a_calf_already _ = True + not_a_caf_already CafCC = False + not_a_caf_already _ = True cafifyCC cc = pprPanic "cafifyCC" (ppr cc) -dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC -dupifyCC (NormalCC kind m g is_dupd is_caf) - = NormalCC kind m g ADupdCC is_caf -dupifyCC cc = pprPanic "dupifyCC" (ppr cc) +dupifyCC cc = cc {cc_is_dupd = DupdCC} isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool isEmptyCC (NoCostCentre) = True isEmptyCC _ = False -isCafCC (AllCafsCC _ _) = True -isCafCC (NormalCC _ _ _ _ IsCafCC) = True -isCafCC _ = False +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_is_caf = CafCC}) = True +isCafCC _ = False -isDictCC (AllDictsCC _ _ _) = True -isDictCC (NormalCC (DictCC _) _ _ _ _) = True -isDictCC _ = False +isDictCC (AllDictsCC {}) = True +isDictCC (NormalCC {cc_is_dict = DictCC}) = True +isDictCC _ = False -isDupdCC (AllDictsCC _ _ ADupdCC) = True -isDupdCC (NormalCC _ _ _ ADupdCC _) = True -isDupdCC _ = False +isDupdCC (AllDictsCC {cc_is_dupd = DupdCC}) = True +isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True +isDupdCC _ = False isSccCountCostCentre :: CostCentre -> Bool -- Is this a cost-centre which records scc counts @@ -268,18 +277,7 @@ sccAbleCostCentre cc | isCafCC cc = False | otherwise = True ccFromThisModule :: CostCentre -> Module -> Bool - -ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name -ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name -ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name -\end{code} - -\begin{code} -ccMentionsId :: CostCentre -> Maybe Id - -ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id -ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id -ccMentionsId other = Nothing +ccFromThisModule cc m = cc_mod cc == m \end{code} \begin{code} @@ -291,13 +289,14 @@ instance Ord CostCentre where cmpCostCentre :: CostCentre -> CostCentre -> Ordering -cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2 -cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2 +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 +cmpCostCentre (AllDictsCC {cc_mod = m1}) (AllDictsCC {cc_mod = m2}) = m1 `compare` m2 -cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) +cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) + (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2}) -- first key is module name, then we use "kinds" (which include -- names) and finally the caf flag - = (m1 `compare` m2) `thenCmp` (k1 `cmp_kind` k2) `thenCmp` (c1 `cmp_caf` c2) + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2) cmpCostCentre other_1 other_2 = let @@ -306,28 +305,14 @@ cmpCostCentre other_1 other_2 in if tag1 _LT_ tag2 then LT else GT where - tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT) - tag_CC (AllCafsCC _ _) = ILIT(2) - tag_CC (AllDictsCC _ _ _) = ILIT(3) - -cmp_kind (UserCC n1) (UserCC n2) = n1 `compare` n2 -cmp_kind (AutoCC i1) (AutoCC i2) = i1 `compare` i2 -cmp_kind (DictCC i1) (DictCC i2) = i1 `compare` i2 -cmp_kind other_1 other_2 - = let - tag1 = tag_CcKind other_1 - tag2 = tag_CcKind other_2 - in - if tag1 _LT_ tag2 then LT else GT - where - tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT) - tag_CcKind (AutoCC _) = ILIT(2) - tag_CcKind (DictCC _) = ILIT(3) - -cmp_caf IsNotCafCC IsCafCC = LT -cmp_caf IsNotCafCC IsNotCafCC = EQ -cmp_caf IsCafCC IsCafCC = EQ -cmp_caf IsCafCC IsNotCafCC = GT + tag_CC (NormalCC {}) = (ILIT(1) :: FAST_INT) + tag_CC (AllCafsCC {}) = ILIT(2) + tag_CC (AllDictsCC {}) = ILIT(3) + +cmp_caf NotCafCC CafCC = LT +cmp_caf NotCafCC NotCafCC = EQ +cmp_caf CafCC CafCC = EQ +cmp_caf CafCC NotCafCC = GT \end{code} ----------------------------------------------------------------------------- @@ -346,26 +331,18 @@ instance Outputable CostCentreStack where OverheadCCS -> ptext SLIT("CCS_OVERHEAD") DontCareCCS -> ptext SLIT("CCS_DONTZuCARE") SubsumedCCS -> ptext SLIT("CCS_SUBSUMED") - SingletonCCS cc -> - getPprStyle $ \sty -> - if (codeStyle sty) - then ptext SLIT("CCS_") <> - ptext (identToC (costCentreStr cc)) - else ptext SLIT("CCS.") <> text (costCentreStr cc) + SingletonCCS cc -> ptext SLIT("CCS_") <> ppr cc pprCostCentreStackDecl :: CostCentreStack -> SDoc - pprCostCentreStackDecl ccs@(SingletonCCS cc) = let - (mod_name, grp_name, is_subsumed, externally_visible) = get_cc_info cc + is_subsumed = ccSubsumed cc in hcat [ ptext SLIT("CCS_DECLARE"), char '(', ppr ccs, comma, -- better be codeStyle ppCostCentreLbl cc, comma, ptext is_subsumed, comma, - if externally_visible - then empty - else ptext SLIT("static"), + empty, -- Now always externally visible text ");" ] @@ -391,39 +368,48 @@ by costCentreName. instance Outputable CostCentre where ppr cc = getPprStyle $ \ sty -> if codeStyle sty - then ppCostCentreLbl cc - else - if ifaceStyle sty - then ppCostCentreIface cc - else text (costCentreStr cc) - -ppCostCentreLbl cc = ptext SLIT("CC_") <> ptext (identToC (costCentreStr cc)) -ppCostCentreIface cc = doubleQuotes (text (costCentreStr cc)) -ppCostCentreName cc = doubleQuotes (text (stringToC (costCentreName cc))) - -costCentreStr (NoCostCentre) = "NO_CC" -costCentreStr (AllCafsCC m _) = "CAFs." ++ moduleString m -costCentreStr (AllDictsCC m _ d) = "DICTs." ++ moduleString m -costCentreStr (NormalCC kind mod_name grp_name is_dupd is_caf) - = case is_caf of { IsCafCC -> "CAF:"; _ -> "" } - ++ moduleString mod_name - ++ case kind of { UserCC name -> _UNPK_ name; - AutoCC id -> getOccString id ++ "/AUTO"; - DictCC id -> getOccString id ++ "/DICT" - } - -- ToDo: group name - ++ case is_dupd of { ADupdCC -> "/DUPD"; _ -> "" } - --- This is the name to go in the cost centre declaration -costCentreName (NoCostCentre) = "NO_CC" -costCentreName (AllCafsCC _ _) = "CAFs_in_..." -costCentreName (AllDictsCC _ _ _) = "DICTs_in_..." -costCentreName (NormalCC kind mod_name grp_name is_dupd is_caf) - = case is_caf of { IsCafCC -> "CAF:"; _ -> "" } - ++ case kind of { UserCC name -> _UNPK_ name; - AutoCC id -> getOccString id; - DictCC id -> getOccString id - } + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in an interface file or in Core generally +pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g}) + = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g)) +pprCostCentreCore (AllDictsCC {cc_mod = m, cc_grp = g, cc_is_dupd = dup}) + = text "__sccD" <+> braces (pprModule m <+> doubleQuotes (ptext g) <+> pp_dup dup) +pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g, + cc_is_dict = dic, cc_is_caf = caf, cc_is_dupd = dup}) + = text "__scc" <+> braces (hsep [ + ptext n, + pprModule m, + doubleQuotes (ptext g), + pp_dict dic, + pp_dup dup, + pp_caf caf + ]) + +pp_dict DictCC = text "__A" +pp_dict other = empty + +pp_dup DupdCC = char '!' +pp_dup other = empty + +pp_caf CafCC = text "__C" +pp_caf other = empty + + +-- Printing as a C label +ppCostCentreLbl (NoCostCentre) = text "CC_NONE" +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = text "CC_CAFs_" <> pprModule m +ppCostCentreLbl (AllDictsCC {cc_mod = m}) = text "CC_DICTs_" <> pprModule m +ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m}) = text "CC_" <> pprModule m <> ptext n + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName (NoCostCentre) = "NO_CC" +costCentreUserName (AllCafsCC {}) = "CAFs_in_..." +costCentreUserName (AllDictsCC {}) = "DICTs_in_..." +costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf}) + = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name) \end{code} Cost Centre Declarations @@ -437,47 +423,23 @@ pprCostCentreDecl is_local cc = if is_local then hcat [ ptext SLIT("CC_DECLARE"),char '(', - cc_ident, comma, - ppCostCentreName cc, comma, - doubleQuotes (pprModule mod_name), comma, - doubleQuotes (ptext grp_name), comma, - ptext is_subsumed, comma, - if externally_visible - then empty - else ptext SLIT("static"), + cc_ident, comma, + text (costCentreUserName cc), comma, + doubleQuotes (text (moduleUserString mod_name)), comma, + doubleQuotes (ptext grp_name), comma, + ptext is_subsumed, comma, + empty, -- Now always externally visible text ");"] else hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ] where - cc_ident = ppCostCentreLbl cc - - (mod_name, grp_name, is_subsumed, externally_visible) - = get_cc_info cc - - -get_cc_info :: CostCentre -> - (Module, -- module - Group, -- group name - FAST_STRING, -- subsumed value - Bool) -- externally visible - -get_cc_info cc - = case cc of - AllCafsCC m g -> (m, g, cc_IS_CAF, True) - - AllDictsCC m g _ -> (m, g, cc_IS_DICT, True) - - NormalCC (DictCC i) m g is_dupd is_caf - -> (m, g, cc_IS_DICT, externallyVisibleId i) - - NormalCC x m g is_dupd is_caf - -> (m, g, do_caf is_caf, - case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i}) - where - cc_IS_CAF = SLIT("CC_IS_CAF") - cc_IS_DICT = SLIT("CC_IS_DICT") - cc_IS_BORING = SLIT("CC_IS_BORING") - - do_caf IsCafCC = cc_IS_CAF - do_caf IsNotCafCC = cc_IS_BORING + cc_ident = ppCostCentreLbl cc + mod_name = cc_mod cc + grp_name = cc_grp cc + is_subsumed = ccSubsumed cc + +ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value +ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF") + | isDictCC cc = SLIT("CC_IS_DICT") + | otherwise = SLIT("CC_IS_BORING") \end{code} diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 46878b7783..42f0a32950 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -116,7 +116,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds -- Top level CAF without a cost centre attached -- Attach CAF cc (collect if individual CAF ccs) = (if opt_AutoSccsOnIndividualCafs - then let cc = mkAutoCC binder mod_name grp_name IsCafCC + then let cc = mkAutoCC binder mod_name grp_name CafCC ccs = mkSingletonCCS cc in collectCC cc `thenMM_` diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 43469027cd..c362f3bc35 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -35,15 +35,14 @@ module Lex ( import Char ( ord, isSpace ) import List ( isSuffixOf ) -import CostCentre -- Pretty much all of it import IdInfo ( InlinePragInfo(..) ) -import Name ( isLowerISO, isUpperISO, mkModule ) - +import Name ( isLowerISO, isUpperISO ) +import OccName ( IfaceFlavour, hiFile, hiBootFile ) import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck ) import Demand ( Demand(..) {- instance Read -} ) import UniqFM ( UniqFM, listToUFM, lookupUFM) -import BasicTypes ( NewOrData(..), IfaceFlavour(..) ) +import BasicTypes ( NewOrData(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile ) import Maybes ( MaybeErr(..) ) @@ -142,7 +141,9 @@ data IfaceToken | ITnocaf | ITunfold InlinePragInfo | ITstrict ([Demand], Bool) - | ITscc CostCentre + | ITscc + | ITsccAllCafs + | ITsccAllDicts | ITdotdot -- reserved symbols | ITdcolon @@ -189,9 +190,6 @@ data IfaceToken | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token deriving Text -- debugging - -instance Text CostCentre -- cheat! - \end{code} %************************************************************************ @@ -281,9 +279,7 @@ lexIface cont buf = (stepOnBy# buf 3#)) -- past __S 's'# -> case prefixMatch (stepOnBy# buf 3#) "cc" of - Just buf' -> lex_scc cont - (stepOnUntil (not . isSpace) - (stepOverLexeme buf')) + Just buf' -> lex_scc cont (stepOverLexeme buf') Nothing -> lex_id cont buf _ -> lex_id cont buf _ -> lex_id cont buf @@ -359,54 +355,9 @@ lex_demand cont buf = ------------------ lex_scc cont buf = case currentChar# buf of - '"'# -> - case prefixMatch (stepOn buf) "CAFs." of - Just buf' -> - case untilChar# (stepOverLexeme buf') '\"'# of - buf'' -> cont (ITscc (mkAllCafsCC (mkModule (lexemeToString buf'')) _NIL_)) - (stepOn (stepOverLexeme buf'')) - Nothing -> - case prefixMatch (stepOn buf) "DICTs." of - Just buf' -> - case untilChar# (stepOverLexeme buf') '\"'# of - buf'' -> cont (ITscc (mkAllDictsCC (mkModule (lexemeToString buf'')) _NIL_ True)) - (stepOn (stepOverLexeme buf'')) - Nothing -> - let - match_user_cc buf = - case untilChar# buf '/'# of - buf' -> - let mod_name = mkModule (lexemeToString buf') in --- case untilChar# (stepOn (stepOverLexeme buf')) '/'# of --- buf'' -> --- let grp_name = lexemeToFastString buf'' in - case untilChar# (stepOn (stepOverLexeme buf')) '\"'# of - buf'' -> - -- The label may contain arbitrary characters, so it - -- may have been escaped etc., hence we `read' it in to get - -- rid of these meta-chars in the string and then pack it (again.) - -- ToDo: do the same for module name (single quotes allowed in m-names). - -- BTW, the code in this module is totally gruesome.. - let upk_label = _UNPK_ (lexemeToFastString buf'') in - case reads ('"':upk_label++"\"") of - ((cc_label,_):_) -> - let cc_name = _PK_ cc_label in - (mkUserCC cc_name mod_name _NIL_{-grp_name-}, - stepOn (stepOverLexeme buf'')) - _ -> - trace ("trouble lexing scc label: " ++ upk_label ++ " , ignoring") - (mkUserCC _NIL_ mod_name _NIL_{-grp_name-}, - stepOn (stepOverLexeme buf'')) - in - case prefixMatch (stepOn buf) "CAF:" of - Just buf' -> - case match_user_cc (stepOverLexeme buf') of - (cc, buf'') -> cont (ITscc (cafifyCC cc)) buf'' - Nothing -> - case match_user_cc (stepOn buf) of - (cc, buf'') -> cont (ITscc cc) buf'' - c -> cont (ITunknown [C# c]) (stepOn buf) - + 'C'# -> cont ITsccAllCafs (stepOverLexeme (stepOn buf)) + 'D'# -> cont ITsccAllDicts (stepOverLexeme (stepOn buf)) + other -> cont ITscc buf ----------- lex_num :: (IfaceToken -> IfM a) -> (Int -> Int) -> Int# -> IfM a @@ -511,8 +462,8 @@ lex_con cont buf = case expandWhile# is_ident buf of { buf1 -> case expandWhile# (eqChar# '#'#) buf1 of { buf' -> case currentChar# buf' of - '.'# -> munch HiFile - '!'# -> munch HiBootFile + '.'# -> munch hiFile + '!'# -> munch hiBootFile _ -> just_a_conid where diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index eeb639e3e2..696c4b5c03 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -23,6 +23,7 @@ module PrefixSyn ( import HsSyn import RdrHsSyn +import RdrName ( RdrName ) import Panic ( panic ) import Char ( isDigit, ord ) diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 79c657aa9c..452e2a5c3d 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -40,32 +40,27 @@ module RdrHsSyn ( RdrNameInstancePragmas, extractHsTyVars, extractHsCtxtTyVars, extractPatsTyVars, - RdrName(..), - qual, varQual, tcQual, varUnqual, - dummyRdrVarName, dummyRdrTcName, - isUnqual, isQual, - rdrNameOcc, rdrNameModule, ieOcc, - cmpRdr, mkOpApp, mkClassDecl - ) where #include "HsVersions.h" import HsSyn -import BasicTypes ( IfaceFlavour(..), Unused ) -import Name ( NamedThing(..), - Module, pprModule, mkModuleFS, - OccName, srcTCOcc, srcVarOcc, isTvOcc, - pprOccName, mkClassTyConOcc, mkClassDataConOcc - ) -import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) +import Name ( mkClassTyConOcc, mkClassDataConOcc ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc ) import Util ( thenCmp ) import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas ) import List ( nub ) import Outputable \end{code} + +%************************************************************************ +%* * +\subsection{Type synonyms} +%* * +%************************************************************************ + \begin{code} type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat type RdrNameBangType = BangType RdrName @@ -99,6 +94,13 @@ type RdrNameGenPragmas = GenPragmas RdrName type RdrNameInstancePragmas = InstancePragmas RdrName \end{code} + +%************************************************************************ +%* * +\subsection{A few functions over HsSyn at RdrName} +%* * +%************************************************************************ + @extractHsTyVars@ looks just for things that could be type variables. It's used when making the for-alls explicit. @@ -125,8 +127,8 @@ extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++ where locals = map getTyVarName tvs -insertTV name@(Unqual occ) acc | isTvOcc occ = name : acc -insertTV other acc = acc +insertTV name acc | isRdrTyVar name = name : acc +insertTV other acc = acc extractPatsTyVars :: [RdrNamePat] -> [RdrName] extractPatsTyVars pats = nub (foldr extract_pat [] pats) @@ -156,92 +158,18 @@ mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 \end{code} mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon -by deriving them from the name of the class. +by deriving them from the name of the class. We fill in the names for the +tycon and datacon corresponding to the class, by deriving them from the +name of the class itself. This saves recording the names in the interface +file (which would be equally godd). \begin{code} mkClassDecl cxt cname tyvars sigs mbinds prags loc = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc where - -- The datacon and tycon are called "_DC" and "_TC", where the class is C - -- This prevents name clashes with user-defined tycons or datacons C - (dname, tname) = case cname of - Qual m occ hif -> (Qual m (mkClassDataConOcc occ) hif, - Qual m (mkClassTyConOcc occ) hif) - Unqual occ -> (Unqual (mkClassDataConOcc occ), - Unqual (mkClassTyConOcc occ)) + cls_occ = rdrNameOcc cname + dname = mkRdrUnqual (mkClassDataConOcc cls_occ) + tname = mkRdrUnqual (mkClassTyConOcc cls_occ) \end{code} -%************************************************************************ -%* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} -%* * -%************************************************************************ - -\begin{code} -data RdrName - = Unqual OccName - | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only), - -- HiFile for the common M.t - --- These ones are used for making RdrNames for known-key things, --- Or in code constructed from derivings -qual (m,n) = Qual m n HiFile -tcQual (m,n) = Qual m (srcTCOcc n) HiFile -varQual (m,n) = Qual m (srcVarOcc n) HiFile -varUnqual n = Unqual (srcVarOcc n) - - -- This guy is used by the reader when HsSyn has a slot for - -- an implicit name that's going to be filled in by - -- the renamer. We can't just put "error..." because - -- we sometimes want to print out stuff after reading but - -- before renaming -dummyRdrVarName = Unqual (srcVarOcc SLIT("V-DUMMY")) -dummyRdrTcName = Unqual (srcVarOcc SLIT("TC-DUMMY")) - - -isUnqual (Unqual _) = True -isUnqual (Qual _ _ _) = False - -isQual (Unqual _) = False -isQual (Qual _ _ _) = True - - -cmpRdr (Unqual n1) (Unqual n2) = n1 `compare` n2 -cmpRdr (Unqual n1) (Qual m2 n2 _) = LT -cmpRdr (Qual m1 n1 _) (Unqual n2) = GT -cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2) - -- always compare module-names *second* - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Qual _ occ _) = occ - -rdrNameModule :: RdrName -> Module -rdrNameModule (Qual m _ _) = m - -ieOcc :: RdrNameIE -> OccName -ieOcc ie = rdrNameOcc (ieName ie) - -instance Show RdrName where -- debugging - showsPrec p rn = showsPrecSDoc p (ppr rn) - -instance Eq RdrName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpRdr a b - -instance Outputable RdrName where - ppr (Unqual n) = pprOccName n - ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n] - -instance NamedThing RdrName where -- Just so that pretty-printing of expressions works - getOccName = rdrNameOcc - getName = panic "no getName for RdrNames" -\end{code} diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index a29c6b3976..7ed114085e 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -14,18 +14,22 @@ import HsSyn import HsTypes ( HsTyVar(..) ) import HsPragmas ( noDataPragmas, noClassPragmas ) import RdrHsSyn -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) +import PrelMods ( pRELUDE ) import PrefixToHs import CallConv import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts ) -import Name ( OccName, srcTvOcc, srcVarOcc, srcTCOcc, - Module, mkModuleFS, - isConOcc, isLexConId, isWildCardOcc +import OccName ( Module, mkSrcModuleFS, mkImportModuleFS, + hiFile, hiBootFile, + NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName, + isLexCon + ) +import RdrName ( RdrName, isRdrDataCon, mkSrcQual, mkSrcUnqual, mkPreludeQual, + dummyRdrVarName ) import Outputable import SrcLoc ( SrcLoc ) -import PrelMods ( pRELUDE ) import FastString ( mkFastCharString ) import PrelRead ( readRational__ ) \end{code} @@ -57,14 +61,18 @@ wlkMaybe wlk_it (U_just x) \end{code} \begin{code} -wlkTCId = wlkQid srcTCOcc -wlkVarId = wlkQid srcVarOcc -wlkDataId = wlkQid srcVarOcc -wlkEntId = wlkQid (\occ -> if isLexConId occ - then srcTCOcc occ - else srcVarOcc occ) - -wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName +wlkTcClsId = wlkQid (\_ -> tcClsName) +wlkTcId = wlkQid (\_ -> tcName) +wlkClsId = wlkQid (\_ -> clsName) +wlkVarId = wlkQid (\occ -> if isLexCon occ + then dataName + else varName) +wlkDataId = wlkQid (\_ -> dataName) +wlkEntId = wlkQid (\occ -> if isLexCon occ + then tcClsName + else varName) + +wlkQid :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName -- There are three kinds of qid: -- qualified name (aqual) A.x @@ -78,22 +86,22 @@ wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which -- case we need to unqualify these things. -- SDM. -wlkQid mk_occ_name (U_noqual name) - = returnUgn (Unqual (mk_occ_name name)) -wlkQid mk_occ_name (U_aqual mod name) - = returnUgn (Qual (mkModuleFS mod) (mk_occ_name name) HiFile) -wlkQid mk_occ_name (U_gid n name) +wlkQid mk_name_space (U_noqual name) + = returnUgn (mkSrcUnqual (mk_name_space name) name) +wlkQid mk_name_space (U_aqual mod name) + = returnUgn (mkSrcQual (mk_name_space name) mod name) +wlkQid mk_name_space (U_gid n name) -- Built in Prelude things | opt_NoImplicitPrelude - = returnUgn (Unqual (mk_occ_name name)) + = returnUgn (mkSrcUnqual (mk_name_space name) name) | otherwise - = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile) + = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE name) -rdTCId pt = rdU_qid pt `thenUgn` wlkTCId +rdTCId pt = rdU_qid pt `thenUgn` wlkTcId rdVarId pt = rdU_qid pt `thenUgn` wlkVarId rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string -wlkTvId string = returnUgn (Unqual (srcTvOcc string)) +wlkTvId string = returnUgn (mkSrcUnqual tvName string) cvFlag :: U_long -> Bool cvFlag 0 = False @@ -119,7 +127,7 @@ rdModule rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist hmodlist srciface_version srcline) -> let - mod_name = mkModuleFS mod_fs + mod_name = mkSrcModuleFS mod_fs in setSrcFileUgn srcfile $ @@ -398,14 +406,15 @@ wlkPat pat wlkLiteral lit `thenUgn` \ lit -> returnUgn (LitPatIn lit) - U_ident nn -> -- simple identifier + U_ident (U_noqual s) | s == SLIT("_")-> returnUgn WildPatIn -- Wild-card pattern + + U_ident nn -> -- simple identifier wlkVarId nn `thenUgn` \ n -> - let occ = rdrNameOcc n in returnUgn ( - if isConOcc occ then + if isRdrDataCon n then ConPatIn n [] else - if (isWildCardOcc occ) then WildPatIn else (VarPatIn n) + VarPatIn n ) U_ap l r -> -- "application": there's a list of patterns lurking here! @@ -745,7 +754,7 @@ wlkHsType ttype returnUgn (MonoTyVar tyvar) U_tname tcon -> -- type constructor - wlkTCId tcon `thenUgn` \ tycon -> + wlkTcId tcon `thenUgn` \ tycon -> returnUgn (MonoTyVar tycon) U_tapp t1 t2 -> @@ -775,11 +784,11 @@ wlkInstType ttype U_forall u_tyvars u_theta inst_head -> wlkList rdTvId u_tyvars `thenUgn` \ tyvars -> wlkContext u_theta `thenUgn` \ theta -> - wlkConAndTys inst_head `thenUgn` \ (clas, tys) -> + wlkClsTys inst_head `thenUgn` \ (clas, tys) -> returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys)) other -> -- something else - wlkConAndTys other `thenUgn` \ (clas, tys) -> + wlkClsTys other `thenUgn` \ (clas, tys) -> returnUgn (HsForAllTy [] [] (MonoDictTy clas tys)) \end{code} @@ -796,22 +805,21 @@ wlkConAndTyVars ttype returnUgn (split ty []) -wlkContext :: U_list -> UgnM RdrNameContext -rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName]) +wlkContext :: U_list -> UgnM RdrNameContext +rdClsTys :: ParseTree -> UgnM (RdrName, [HsType RdrName]) -wlkContext list = wlkList rdConAndTys list +wlkContext list = wlkList rdClsTys list -rdConAndTys pt = rdU_ttype pt `thenUgn` wlkConAndTys +rdClsTys pt = rdU_ttype pt `thenUgn` wlkClsTys -wlkConAndTys ttype - = wlkHsType ttype `thenUgn` \ ty -> - let - split (MonoTyApp fun ty) tys = split fun (ty : tys) - split (MonoTyVar tycon) tys = (tycon, tys) - split other tys = pprPanic "ERROR: malformed type: " - (ppr other) - in - returnUgn (split ty []) +wlkClsTys ttype + = go ttype [] + where + go (U_tname tcon) tys = wlkClsId tcon `thenUgn` \ cls -> + returnUgn (cls, tys) + + go (U_tapp t1 t2) tys = wlkHsType t2 `thenUgn` \ ty2 -> + go t1 (ty2 : tys) \end{code} \begin{code} @@ -903,10 +911,9 @@ rdImport pt mkSrcLocUgn srcline $ \ src_loc -> wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as -> wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec -> - returnUgn (ImportDecl (mkModuleFS imod) + returnUgn (ImportDecl (mkImportModuleFS imod (cvIfaceFlavour isrc)) (cvFlag iqual) - (cvIfaceFlavour isrc) - (case maybe_as of { Just m -> Just (mkModuleFS m); Nothing -> Nothing }) + (case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing }) maybe_spec src_loc) where rd_spec pt = rdU_either pt `thenUgn` \ spec -> @@ -916,8 +923,8 @@ rdImport pt U_right pt -> rdEntities pt `thenUgn` \ ents -> returnUgn (True, ents) -cvIfaceFlavour 0 = HiFile -- No pragam -cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-} +cvIfaceFlavour 0 = hiFile -- No pragam +cvIfaceFlavour 1 = hiBootFile -- {-# SOURCE #-} \end{code} \begin{code} @@ -929,25 +936,25 @@ rdEntity pt = rdU_entidt pt `thenUgn` \ entity -> case entity of U_entid evar -> -- just a value - wlkEntId evar `thenUgn` \ var -> + wlkEntId evar `thenUgn` \ var -> returnUgn (IEVar var) U_enttype x -> -- abstract type constructor/class - wlkTCId x `thenUgn` \ thing -> + wlkTcClsId x `thenUgn` \ thing -> returnUgn (IEThingAbs thing) U_enttypeall x -> -- non-abstract type constructor/class - wlkTCId x `thenUgn` \ thing -> + wlkTcClsId x `thenUgn` \ thing -> returnUgn (IEThingAll thing) U_enttypenamed x ns -> -- non-abstract type constructor/class -- with specified constrs/methods - wlkTCId x `thenUgn` \ thing -> + wlkTcClsId x `thenUgn` \ thing -> wlkList rdVarId ns `thenUgn` \ names -> returnUgn (IEThingWith thing names) U_entmod mod -> -- everything provided unqualified by a module - returnUgn (IEModuleContents (mkModuleFS mod)) + returnUgn (IEModuleContents (mkSrcModuleFS mod)) \end{code} diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index c1f74baf46..8b8a6223b0 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -9,22 +9,26 @@ import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsTypes ( mkHsForAllTy ) import HsCore import Const ( Literal(..), mkMachInt_safe ) -import BasicTypes ( IfaceFlavour(..), Fixity(..), FixityDirection(..), +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), Version ) +import CostCentre ( CostCentre(..), IsDictCC(..), IsCafCC(..), IsDupdCC(..) ) import HsPragmas ( noDataPragmas, noClassPragmas ) import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind ) import IdInfo ( ArityInfo, exactArity ) import Lex -import RnEnv ( ifaceUnqualTC, ifaceUnqualVar, ifaceUnqualTv, ifaceQualVar, ifaceQualTC ) import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..), RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..) ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName, isTCOcc, Provenance, Module, - varOcc, tcOcc, mkModuleFS +import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual ) +import Name ( OccName, Provenance, Module ) +import OccName ( mkSysModuleFS, mkSysOccFS, + tcName, varName, dataName, clsName, tvName, + IfaceFlavour, hiFile, hiBootFile, + EncodedFS ) import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName ) @@ -86,8 +90,9 @@ import Ratio ( (%) ) '__litlit' { ITlit_lit } '__string' { ITstring_lit } '__ccall' { ITccall $$ } - '__scc' { ITscc $$ } - '__a' { ITtypeapp } + '__scc' { ITscc } + '__sccC' { ITsccAllCafs } + '__sccD' { ITsccAllDicts } '__A' { ITarity } '__P' { ITspecialise } @@ -175,8 +180,8 @@ import_part : { [] } | import_part import_decl { $2 : $1 } import_decl :: { ImportVersion OccName } -import_decl : 'import' mod_name opt_bang INTEGER '::' whats_imported ';' - { ($2, $3, fromInteger $4, $6) } +import_decl : 'import' mod_fs opt_bang INTEGER '::' whats_imported ';' + { (mkSysModuleFS $2 $3, fromInteger $4, $6) } whats_imported :: { WhatsImported OccName } whats_imported : { Everything } @@ -187,7 +192,8 @@ name_version_pairs : { [] } | name_version_pair name_version_pairs { $1 : $2 } name_version_pair :: { LocalVersion OccName } -name_version_pair : entity_occ INTEGER { ($1, fromInteger $2) } +name_version_pair : var_occ INTEGER { ($1, fromInteger $2) } + | tc_occ INTEGER { ($1, fromInteger $2) } instance_import_part :: { [Module] } instance_import_part : { [] } @@ -198,27 +204,35 @@ instance_import_part : { [] } exports_part :: { [ExportItem] } exports_part : { [] } - | exports_part '__export' opt_bang mod_name entities ';' - { ($4,$3,$5) : $1 } + | exports_part '__export' opt_bang mod_fs entities ';' + { (mkSysModuleFS $4 $3,$5) : $1 } opt_bang :: { IfaceFlavour } -opt_bang : { HiFile } - | '!' { HiBootFile } +opt_bang : { hiFile } + | '!' { hiBootFile } entities :: { [RdrAvailInfo] } -entities : { [] } - | entity entities { $1 : $2 } +entities : { [] } + | entity entities { $1 : $2 } entity :: { RdrAvailInfo } -entity : entity_occ { if isTCOcc $1 - then AvailTC $1 [$1] - else Avail $1 } - | entity_occ stuff_inside { AvailTC $1 ($1:$2) } - | entity_occ '|' stuff_inside { AvailTC $1 $3 } +entity : tc_occ { AvailTC $1 [$1] } + | var_occ { Avail $1 } + | tc_occ stuff_inside { AvailTC $1 ($1:$2) } + | tc_occ '|' stuff_inside { AvailTC $1 $3 } stuff_inside :: { [OccName] } stuff_inside : '{' val_occs '}' { $2 } +val_occ :: { OccName } + : var_occ { $1 } + | data_occ { $1 } + +val_occs :: { [OccName] } + : val_occ { [$1] } + | val_occ val_occs { $1 : $2 } + + -------------------------------------------------------------------------- fixity :: { FixityDirection } @@ -274,15 +288,15 @@ 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 data_fs tv_bndrs constrs - { TyClD (TyData DataType $3 (ifaceUnqualTC $4) $5 $6 Nothing noDataPragmas $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 csigs { TyClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds noClassPragmas $1) } - | src_loc fixity mb_fix val_occ - { FixD (FixitySig (Unqual $4) (Fixity $3 $2) $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 -} { \_ -> [] } @@ -313,8 +327,8 @@ constrs1 : constr { [$1] } | constr '|' constrs1 { $1 : $3 } constr :: { RdrNameConDecl } -constr : src_loc ex_stuff data_fs batypes { mkConDecl (ifaceUnqualVar $3) $2 (VanillaCon $4) $1 } - | src_loc ex_stuff data_fs '{' fields1 '}' { mkConDecl (ifaceUnqualVar $3) $2 (RecCon $5) $1 } +constr : src_loc ex_stuff data_name batypes { mkConDecl $3 $2 (VanillaCon $4) $1 } + | src_loc ex_stuff data_name '{' fields1 '}' { mkConDecl $3 $2 (RecCon $5) $1 } -- We use "data_fs" so as to include () newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} } @@ -362,7 +376,7 @@ context_list1 : class { [$1] } | class ',' context_list1 { $1 : $3 } class :: { (RdrName, [RdrNameHsType]) } -class : qtc_name atypes { ($1, $2) } +class : qcls_name atypes { ($1, $2) } types2 :: { [RdrNameHsType] {- Two or more -} } types2 : type ',' type { [$1,$3] } @@ -375,59 +389,48 @@ btype : atype { $1 } atype :: { RdrNameHsType } atype : qtc_name { MonoTyVar $1 } | tv_name { MonoTyVar $1 } - | '(' ')' { MonoTupleTy [] True } | '(' types2 ')' { MonoTupleTy $2 True{-boxed-} } | '(#' type '#)' { MonoTupleTy [$2] False{-unboxed-} } | '(#' types2 '#)' { MonoTupleTy $2 False{-unboxed-} } | '[' type ']' { MonoListTy $2 } - | '{' qtc_name atypes '}' { MonoDictTy $2 $3 } + | '{' qcls_name atypes '}' { MonoDictTy $2 $3 } | '(' type ')' { $2 } +-- This one is dealt with via qtc_name +-- | '(' ')' { MonoTupleTy [] True } + atypes :: { [RdrNameHsType] {- Zero or more -} } atypes : { [] } | atype atypes { $1 : $2 } --------------------------------------------------------------------- +mod_fs :: { EncodedFS } + : CONID { $1 } mod_name :: { Module } - : CONID { mkModuleFS $1 } + : mod_fs { mkSysModuleFS $1 hiFile } -var_fs :: { FAST_STRING } + +--------------------------------------------------- +var_fs :: { EncodedFS } : VARID { $1 } | VARSYM { $1 } | '-' { SLIT("-") } | '!' { SLIT("!") } -data_fs :: { FAST_STRING } - : CONID { $1 } - | CONSYM { $1 } - | '->' { SLIT("->") } - | '(' ')' { SLIT("()") } - | '(' commas ')' { snd (mkTupNameStr $2) } - | '[' ']' { SLIT("[]") } - -commas :: { Int } - : ',' { 2 } - | commas ',' { $1 + 1 } -val_occ :: { OccName } - : var_fs { varOcc $1 } - | data_fs { varOcc $1 } +qvar_fs :: { (EncodedFS, EncodedFS, IfaceFlavour) } + : QVARID { $1 } + | QVARSYM { $1 } -val_occs :: { [OccName] } - : val_occ { [$1] } - | val_occ val_occs { $1 : $2 } - -entity_occ :: { OccName } - : var_fs { varOcc $1 } - | data_fs { tcOcc $1 } +var_occ :: { OccName } + : var_fs { mkSysOccFS varName $1 } var_name :: { RdrName } -var_name : var_fs { ifaceUnqualVar $1 } +var_name : var_occ { mkRdrUnqual $1 } qvar_name :: { RdrName } qvar_name : var_name { $1 } - | QVARID { ifaceQualVar $1 } - | QVARSYM { ifaceQualVar $1 } + | qvar_fs { mkSysQual varName $1 } var_names :: { [RdrName] } var_names : { [] } @@ -436,45 +439,74 @@ var_names : { [] } var_names1 :: { [RdrName] } var_names1 : var_name var_names { $1 : $2 } +--------------------------------------------------- +-- For some bizarre reason, +-- (,,,) is dealt with by the parser +-- Foo.(,,,) is dealt with by the lexer +-- Sigh + +data_fs :: { EncodedFS } + : CONID { $1 } + | CONSYM { $1 } + +qdata_fs :: { (EncodedFS, EncodedFS, IfaceFlavour) } + : QCONID { $1 } + | QCONSYM { $1 } + +data_occ :: { OccName } + : data_fs { mkSysOccFS dataName $1 } + data_name :: { RdrName } - : CONID { ifaceUnqualVar $1 } - | CONSYM { ifaceUnqualVar $1 } - | '(' commas ')' { ifaceUnqualVar (snd (mkTupNameStr $2)) } - | '[' ']' { ifaceUnqualVar SLIT("[]") } + : data_occ { mkRdrUnqual $1 } qdata_name :: { RdrName } qdata_name : data_name { $1 } - | QCONID { ifaceQualVar $1 } - | QCONSYM { ifaceQualVar $1 } + | qdata_fs { mkSysQual dataName $1 } qdata_names :: { [RdrName] } qdata_names : { [] } | qdata_name qdata_names { $1 : $2 } +var_or_data_name :: { RdrName } + : var_name { $1 } + | data_name { $1 } + +--------------------------------------------------- +tc_fs :: { EncodedFS } + : data_fs { $1 } + +tc_occ :: { OccName } + : tc_fs { mkSysOccFS tcName $1 } + tc_name :: { RdrName } -tc_name : CONID { ifaceUnqualTC $1 } - | CONSYM { ifaceUnqualTC $1 } - | '(' '->' ')' { ifaceUnqualTC SLIT("->") } - | '(' commas ')' { ifaceUnqualTC (snd (mkTupNameStr $2)) } - | '[' ']' { ifaceUnqualTC SLIT("[]") } + : tc_occ { mkRdrUnqual $1 } qtc_name :: { RdrName } -qtc_name : tc_name { $1 } - | QCONID { ifaceQualTC $1 } - | QCONSYM { ifaceQualTC $1 } + : tc_name { $1 } + | qdata_fs { mkSysQual tcName $1 } + +--------------------------------------------------- +cls_name :: { RdrName } + : data_fs { mkSysUnqual clsName $1 } + +qcls_name :: { RdrName } + : cls_name { $1 } + | qdata_fs { mkSysQual clsName $1 } +--------------------------------------------------- tv_name :: { RdrName } -tv_name : VARID { ifaceUnqualTv $1 } - | VARSYM { ifaceUnqualTv $1 {- Allow t2 as a tyvar -} } + : VARID { mkSysUnqual tvName $1 } + | VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} } tv_bndr :: { HsTyVar RdrName } -tv_bndr : tv_name '::' akind { IfaceTyVar $1 $3 } + : tv_name '::' akind { IfaceTyVar $1 $3 } | tv_name { IfaceTyVar $1 boxedTypeKind } tv_bndrs :: { [HsTyVar RdrName] } : { [] } | tv_bndr tv_bndrs { $1 : $2 } +--------------------------------------------------- kind :: { Kind } : akind { $1 } | akind '->' kind { mkArrowKind $1 $3 } @@ -531,17 +563,17 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 } | con_or_primop '{' core_args '}' { UfCon $1 $3 } | '__litlit' STRING atype { UfCon (UfLitLitCon $2 $3) [] } - | '__inline' core_expr { UfNote UfInlineCall $2 } - | '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 } - | '__scc' core_expr { UfNote (UfSCC $1) $2 } - | fexpr { $1 } + | '__inline' 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 } | core_aexpr { $1 } core_arg :: { UfExpr RdrName } - : '__a' atype { UfType $2 } + : '@' atype { UfType $2 } | core_aexpr { $1 } core_args :: { [UfExpr RdrName] } @@ -563,11 +595,13 @@ core_aexpr : qvar_name { UfVar $1 } | core_lit { UfCon (UfLitCon $1) [] } | '(' core_expr ')' { $2 } - | '(' ')' { UfTuple (mkTupConRdrName 0) [] } | '(' comma_exprs2 ')' { UfTuple (mkTupConRdrName (length $2)) $2 } | '(#' core_expr '#)' { UfTuple (mkUbxTupConRdrName 1) [$2] } | '(#' comma_exprs2 '#)' { UfTuple (mkUbxTupConRdrName (length $2)) $2 } +-- This one is dealt with by qdata_name: see above comments +-- | '(' ')' { UfTuple (mkTupConRdrName 0) [] } + comma_exprs2 :: { [UfExpr RdrName] } -- Two or more comma_exprs2 : core_expr ',' core_expr { [$1,$3] } | core_expr ',' comma_exprs2 { $1 : $3 } @@ -596,16 +630,12 @@ core_pat :: { (UfCon RdrName, [RdrName]) } core_pat : core_lit { (UfLitCon $1, []) } | '__litlit' STRING atype { (UfLitLitCon $2 $3, []) } | qdata_name var_names { (UfDataCon $1, $2) } - | '(' comma_var_names ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) } + | '(' comma_var_names1 ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) } | '(#' comma_var_names1 '#)' { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) } | '__DEFAULT' { (UfDefault, []) } | '(' core_pat ')' { $2 } -comma_var_names :: { [RdrName] } -- Zero, or two or more -comma_var_names : { [] } - | var_name ',' comma_var_names1 { $1 : $3 } - comma_var_names1 :: { [RdrName] } -- One or more comma_var_names1 : var_name { [$1] } | var_name ',' comma_var_names1 { $1 : $3 } @@ -641,14 +671,39 @@ core_val_bndr :: { UfBinder RdrName } core_val_bndr : var_name '::' atype { UfValBinder $1 $3 } core_tv_bndr :: { UfBinder RdrName } -core_tv_bndr : '__a' tv_name '::' akind { UfTyBinder $2 $4 } - | '__a' tv_name { UfTyBinder $2 boxedTypeKind } +core_tv_bndr : '@' tv_name '::' akind { UfTyBinder $2 $4 } + | '@' tv_name { UfTyBinder $2 boxedTypeKind } ccall_string :: { FAST_STRING } : STRING { $1 } | VARID { $1 } | CONID { $1 } +------------------------------------------------------------------------ +scc :: { CostCentre } + : '__sccC' '{' mod_name STRING '}' { AllCafsCC $3 $4 } + | '__sccD' '{' mod_name STRING cc_dup '}' { AllDictsCC $3 $4 $5 } + | '__scc' '(' cc_name mod_name STRING cc_dict cc_dup cc_caf '}' + { NormalCC { cc_name = $3, cc_mod = $4, cc_grp = $5, + cc_is_dict = $6, cc_is_dupd = $7, cc_is_caf = $8 } } + +cc_name :: { EncodedFS } + : CONID { $1 } + | VARID { $1 } + +cc_dup :: { IsDupdCC } +cc_dup : { OriginalCC } + | '!' { DupdCC } + +cc_caf :: { IsCafCC } + : { NotCafCC } + | '__C' { CafCC } + +cc_dict :: { IsDictCC } + : { VanillaCC } + | '__A' { DictCC } + + ------------------------------------------------------------------- src_loc :: { SrcLoc } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 91a7b84129..f9aafff576 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -9,7 +9,7 @@ module Rename ( renameModule ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrName(..), RdrNameHsModule ) +import RdrHsSyn ( RdrNameHsModule ) import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames ) import CmdLineOpts ( opt_HiMap, opt_D_show_rn_trace, @@ -23,12 +23,15 @@ import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpeci getDeferredDataDecls, mkSearchPath, getSlurpedNames, getRnStats ) -import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet, warnUnusedTopNames ) +import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet, + warnUnusedTopNames + ) import Name ( Name, isLocallyDefined, NamedThing(..), ImportReason(..), Provenance(..), nameModule, pprModule, pprOccName, nameOccName, - getNameProvenance + getNameProvenance, occNameUserString, ) +import RdrName ( RdrName ) import NameSet import TyCon ( TyCon ) import PrelMods ( mAIN, pREL_MAIN ) @@ -102,7 +105,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) in -- RENAME THE SOURCE - initRnMS rn_env mod_name SourceMode ( + initRnMS rn_env SourceMode ( addImplicits mod_name `thenRn_` rnSourceDecls local_decls ) `thenRn` \ (rn_local_decls, fvs) -> @@ -143,7 +146,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) -- RETURN THE RENAMED MODULE let - import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] + import_mods = [mod | ImportDecl mod _ _ _ _ <- imports] renamed_module = HsModule mod_name vers trashed_exports trashed_imports @@ -227,7 +230,7 @@ slurpDecls decls \end{code} \begin{code} -closeDecls :: RnSMode +closeDecls :: RnMode -> [RenamedHsDecl] -- Declarations got so far -> RnMG [RenamedHsDecl] -- input + extra decls slurped -- The monad includes a list of possibly-unresolved Names @@ -257,7 +260,8 @@ closeDecls mode decls mod_name = nameModule (fst name_w_loc) rn_iface_decl mod_name mode decl - = initRnMS emptyRnEnv mod_name mode (rnIfaceDecl decl) + = setModuleRn mod_name $ + initRnMS emptyRnEnv mode (rnIfaceDecl decl) rn_inst_decl mode (mod_name,decl) = rn_iface_decl mod_name mode (InstD decl) rn_data_decl mode (mod_name,ty_decl) = rn_iface_decl mod_name mode (TyClD ty_decl) @@ -284,36 +288,28 @@ reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentio ] defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) - defined_but_not_used = defined_names `minusNameSet` really_used_names - - -- Filter out the ones only defined implicitly or whose OccNames - -- start with an '_', which we won't report. - bad_guys = filter is_explicit (nameSetToList defined_but_not_used) - is_explicit n = case getNameProvenance n of - LocalDef _ _ -> True - NonLocalDef (UserImport _ _ explicit) _ _ -> explicit - other -> False - - -- Now group by whether locally defined or imported; - -- one group is the locally-defined ones, one group per import module - groups = equivClasses cmp bad_guys - where - name1 `cmp` name2 = getNameProvenance name1 `cmph` getNameProvenance name2 - - cmph (LocalDef _ _) (NonLocalDef _ _ _) = LT - cmph (LocalDef _ _) (LocalDef _ _) = EQ - cmph (NonLocalDef (UserImport m1 _ _) _ _) - (NonLocalDef (UserImport m2 _ _) _ _) - = m1 `compare` m2 - cmph (NonLocalDef _ _ _) (LocalDef _ _) = GT - -- In-scope NonLocalDefs must have UserImport info on them - - -- ToDo: report somehow on T(..) things where no constructors - -- are imported + defined_but_not_used = nameSetToList (defined_names `minusNameSet` really_used_names) + + -- Filter out the ones only defined implicitly + bad_guys = filter reportableUnusedName defined_but_not_used in - mapRn warnUnusedTopNames groups `thenRn_` + warnUnusedTopNames bad_guys `thenRn_` returnRn () +reportableUnusedName :: Name -> Bool +reportableUnusedName name + = explicitlyImported (getNameProvenance name) && + not (startsWithUnderscore (occNameUserString (nameOccName name))) + where + explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars + explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports + explicitlyImported other = False -- Don't report others + + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". + startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting + startsWithUnderscore other = False -- with an underscore + rnStats :: [RenamedHsDecl] -> RnMG () rnStats all_decls | opt_D_show_rn_trace || diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 31e376be00..03752ef275 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -26,7 +26,7 @@ import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn, - isUnboundName, warnUnusedBinds, + isUnboundName, warnUnusedLocalBinds, FreeVars, emptyFVs, plusFV, plusFVs, unitFV ) import CmdLineOpts ( opt_WarnMissingSigs ) @@ -220,7 +220,7 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds all_fvs = result_fvs `plusFV` bind_fvs unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) in - warnUnusedBinds unused_binders `thenRn_` + warnUnusedLocalBinds unused_binders `thenRn_` returnRn (result, delListFromNameSet all_fvs new_mbinders) where mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) @@ -251,7 +251,7 @@ rn_mono_binds top_lev binders mbinds sigs -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - renameSigs top_lev False binders sigs `thenRn` \ siglist -> + renameSigs top_lev False binders sigs `thenRn` \ (siglist, sig_fvs) -> flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> -- Do the SCC analysis @@ -262,7 +262,7 @@ rn_mono_binds top_lev binders mbinds sigs -- Deal with bound and free-var calculation rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] in - returnRn (final_binds, rhs_fvs) + returnRn (final_binds, rhs_fvs `plusFV` sig_fvs) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks @@ -361,6 +361,9 @@ rnMethodBinds mbind@(PatMonoBind other_pat _ locn) -- acct in the dependency analysis (or we get an -- unexpected out-of-scope error)! WDP 95/07 +-- This is only necessary for the dependency analysis. The free vars +-- of the types in the signatures is gotten from renameSigs + sig_fv (SpecSig _ _ (Just blah) _) acc = acc `plusFV` unitFV blah sig_fv _ acc = acc \end{code} @@ -441,11 +444,11 @@ renameSigs :: TopLevelFlag -- hence SPECIALISE instance prags ok -> NameSet -- Set of names bound in this group -> [RdrNameSig] - -> RnMS s [RenamedSig] -- List of Sig constructors + -> RnMS s ([RenamedSig], FreeVars) -- List of Sig constructors renameSigs top_lev inst_decl binders sigs = -- Rename the signatures - mapRn renameSig sigs `thenRn` \ sigs' -> + mapAndUnzipRn renameSig sigs `thenRn` \ (sigs', fvs_s) -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group @@ -472,46 +475,54 @@ renameSigs top_lev inst_decl binders sigs ) `thenRn_` mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` - returnRn sigs' -- bad ones and all: - -- we need bindings of *some* sort for every name + returnRn (sigs', plusFVs fvs_s) -- bad ones and all: + -- we need bindings of *some* sort for every name +-- We use lookupOccRn in the signatures, which is a little bit unsatisfactory +-- becuase this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupBndrRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,_) -> - returnRn (Sig new_v new_ty src_loc) + lookupOccRn v `thenRn` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> + returnRn (Sig new_v new_ty src_loc, fvs) renameSig (SpecInstSig ty src_loc) = pushSrcLocRn src_loc $ - rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, _) -> - returnRn (SpecInstSig new_ty src_loc) + rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> + returnRn (SpecInstSig new_ty src_loc, fvs) renameSig (SpecSig v ty using src_loc) = pushSrcLocRn src_loc $ - lookupBndrRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,_) -> - rn_using using `thenRn` \ new_using -> - returnRn (SpecSig new_v new_ty new_using src_loc) + lookupOccRn v `thenRn` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs1) -> + rn_using using `thenRn` \ (new_using,fvs2) -> + returnRn (SpecSig new_v new_ty new_using src_loc, fvs1 `plusFV` fvs2) where - rn_using Nothing = returnRn Nothing + rn_using Nothing = returnRn (Nothing, emptyFVs) rn_using (Just x) = lookupOccRn x `thenRn` \ new_x -> - returnRn (Just new_x) + returnRn (Just new_x, unitFV new_x) renameSig (InlineSig v src_loc) = pushSrcLocRn src_loc $ - lookupBndrRn v `thenRn` \ new_v -> - returnRn (InlineSig new_v src_loc) + lookupOccRn v `thenRn` \ new_v -> + returnRn (InlineSig new_v src_loc, emptyFVs) renameSig (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ - lookupBndrRn v `thenRn` \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc)) + lookupOccRn v `thenRn` \ new_v -> + returnRn (FixSig (FixitySig new_v fix src_loc), emptyFVs) renameSig (NoInlineSig v src_loc) = pushSrcLocRn src_loc $ - lookupBndrRn v `thenRn` \ new_v -> - returnRn (NoInlineSig new_v src_loc) + lookupOccRn v `thenRn` \ new_v -> + returnRn (NoInlineSig new_v src_loc, emptyFVs) \end{code} Checking for distinct signatures; oh, so boring diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6114665c2f..7bdc834f68 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -11,23 +11,22 @@ module RnEnv where -- Export everything import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn -import RdrHsSyn ( RdrName(..), RdrNameIE, - rdrNameOcc, isQual, qual - ) +import RdrHsSyn ( RdrNameIE ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, mkRdrUnqual, qualifyRdrName ) import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..) ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkGlobalName, - nameOccName, - pprOccName, isLocalName, isLocallyDefined, isAnonOcc, + mkLocalName, mkGlobalName, isSystemName, + nameOccName, nameModule, setNameModule, + pprOccName, isLocallyDefined, nameUnique, nameOccName, setNameProvenance, getNameProvenance, pprNameProvenance ) import NameSet -import OccName ( OccName, mkModuleFS, - mkDFunOcc, tcOcc, varOcc, tvOcc, - isVarOcc, occNameFlavour, occNameString +import OccName ( OccName, + mkDFunOcc, + occNameFlavour, moduleIfaceFlavour ) import TyCon ( TyCon ) import FiniteMap @@ -36,85 +35,76 @@ import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups ) +import Util ( removeDups, equivClasses, thenCmp ) import List ( nub ) +import Maybes ( mapMaybe ) +import Char ( isAlphanum ) \end{code} %********************************************************* %* * -\subsection{Making new rdr names} -%* * -%********************************************************* - -These functions make new RdrNames from stuff read from an interface file - -\begin{code} -ifaceQualTC (m,n,hif) = Qual (mkModuleFS m) (tcOcc n) hif -ifaceQualVar (m,n,hif) = Qual (mkModuleFS m) (varOcc n) hif - -ifaceUnqualTC n = Unqual (tcOcc n) -ifaceUnqualVar n = Unqual (varOcc n) -ifaceUnqualTv n = Unqual (tvOcc n) -\end{code} - -%********************************************************* -%* * \subsection{Making new names} %* * %********************************************************* \begin{code} -newImportedGlobalName :: Module -> OccName -> IfaceFlavour +newImportedGlobalName :: Module -> OccName -> RnM s d Name -newImportedGlobalName mod occ hif +newImportedGlobalName mod occ = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let - key = (mod,occ) - prov = NonLocalDef ImplicitImport hif False - -- For in-scope things we improve the provenance in RnNames.qualifyImports + key = (mod,occ) + mod_hif = moduleIfaceFlavour mod in case lookupFM cache key of -- A hit in the cache! - -- If it has no provenance at the moment then set its provenance + -- Make sure that the module in the name has the same IfaceFlavour as + -- the module we are looking for; if not, make it so -- so that it has the right HiFlag component. -- (This is necessary for known-key things. -- For example, GHCmain.lhs imports as SOURCE -- Main; but Main.main is a known-key thing.) - -- Don't fiddle with the provenance if it already has one - Just name -> case getNameProvenance name of - NoProvenance -> let - new_name = setNameProvenance name prov - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - other -> returnRn name + Just name | isSystemName name -- A known-key name; fix the provenance and module + -> getOmitQualFn `thenRn` \ omit_fn -> + let + new_name = fixupSystemName name mod (NonLocalDef ImplicitImport (omit_fn name)) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + returnRn new_name + + | otherwise + -> returnRn name Nothing -> -- Miss in the cache! -- Build a new original name, and put it in the cache + getOmitQualFn `thenRn` \ omit_fn -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - name = mkGlobalName uniq mod occ prov + name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport (omit_fn name)) + -- For in-scope things we improve the provenance + -- in RnNames.importsFromImportDecl new_cache = addToFM cache key name in setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn name -newImportedGlobalFromRdrName (Qual mod_name occ hif) - = newImportedGlobalName mod_name occ hif +newImportedGlobalFromRdrName rdr_name + | isQual rdr_name + = newImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) -newImportedGlobalFromRdrName (Unqual occ) + | otherwise = -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. getModuleRn `thenRn ` \ mod_name -> - newImportedGlobalName mod_name occ HiFile + newImportedGlobalName mod_name (rdrNameOcc rdr_name) newLocallyDefinedGlobalName :: Module -> OccName @@ -168,8 +158,7 @@ newLocalNames rdr_names n = length rdr_names (us', us1) = splitUniqSupply us uniqs = uniqsFromSupply n us1 - -- Note: we're not making use of the source location. Not good. - locals = [ mkLocalName uniq (rdrNameOcc rdr_name) + locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs ] in @@ -177,8 +166,7 @@ newLocalNames rdr_names returnRn locals newDFunName cl_occ tycon_occ (Just n) src_loc -- Imported ones have "Just n" - = getModuleRn `thenRn` \ mod_name -> - newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} + = newImportedGlobalFromRdrName n newDFunName cl_occ tycon_occ Nothing src_loc -- Local instance decls have a "Nothing" = getModuleRn `thenRn` \ mod_name -> @@ -192,7 +180,7 @@ newDFunName cl_occ tycon_occ Nothing src_loc -- Local instance decls have a "No -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc isUnboundName :: Name -> Bool isUnboundName name = getUnique name == unboundKey @@ -243,17 +231,18 @@ bindLocalsFVRn doc_str rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvRn :: [HsTyVar Name] -> RnMS s a -> RnMS s a +extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS s (a, FreeVars) -> RnMS s (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl -extendTyVarEnvRn tyvars enclosed_scope +extendTyVarEnvFVRn tyvars enclosed_scope = getLocalNameEnv `thenRn` \ env -> let - new_env = addListToRdrEnv env [ (Unqual (getOccName name), name) - | tyvar <- tyvars, - let name = getTyVarName tyvar + tyvar_names = map getTyVarName tyvars + new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name) + | name <- tyvar_names ] in - setLocalNameEnv new_env enclosed_scope + setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs tyvar_names) bindTyVarsRn :: SDoc -> [HsTyVar RdrName] -> ([HsTyVar Name] -> RnMS s a) @@ -310,12 +299,6 @@ checkDupNames doc_str rdr_names_w_loc returnRn () where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc - - --- Yuk! -ifaceFlavour name = case getNameProvenance name of - NonLocalDef _ hif _ -> hif - other -> HiFile -- Shouldn't happen \end{code} @@ -328,26 +311,29 @@ ifaceFlavour name = case getNameProvenance name of Looking up a name in the RnEnv. \begin{code} -checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name -checkUnboundRn rdr_name (Just name) - = -- Found it! - returnRn name +lookupBndrRn rdr_name + = getNameEnvs `thenRn` \ (global_env, local_env) -> + + -- Try local env + case lookupRdrEnv local_env rdr_name of { + Just name -> returnRn name ; + Nothing -> -checkUnboundRn rdr_name Nothing - = -- Not found by lookup getModeRn `thenRn` \ mode -> case mode of - -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - - -- Not found when processing an imported declaration, - -- so we create a new name for the purpose - InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name - -lookupBndrRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - checkUnboundRn rdr_name maybe_name + InterfaceMode _ -> -- Look in the global name cache + newImportedGlobalFromRdrName rdr_name + + SourceMode -> -- Source mode, so look up a *qualified* version + -- of the name, so that we get the right one even + -- if there are many with the same occ name + -- There must *be* a binding + getModuleRn `thenRn` \ mod -> + case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of + Just (name:rest) -> ASSERT( null rest ) + returnRn 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. @@ -355,12 +341,9 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - checkUnboundRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' + = getNameEnvs `thenRn` \ (global_env, local_env) -> + lookup_occ global_env local_env rdr_name `thenRn` \ name -> + addOccurrenceName name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for @@ -368,26 +351,33 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn :: RdrName -> RnMS s Name lookupGlobalOccRn rdr_name - = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> - checkUnboundRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' + = getNameEnvs `thenRn` \ (global_env, local_env) -> + lookup_global_occ global_env rdr_name `thenRn` \ name -> + addOccurrenceName name +-- Look in both local and global env +lookup_occ global_env local_env rdr_name + = case lookupRdrEnv local_env rdr_name of + Just name -> returnRn name + Nothing -> lookup_global_occ global_env rdr_name --- mungePrintUnqual is used to make *imported* *occurrences* print unqualified --- if they were mentioned unqualified in the source code. --- This improves error messages from the type checker. --- NB: the binding site is treated differently; see lookupBndrRn --- After the type checker all occurrences are replaced by the one --- at the binding site. -mungePrintUnqual (Qual _ _ _) name = name -mungePrintUnqual (Unqual _) name - = case getNameProvenance name of - NonLocalDef imp hif False -> setNameProvenance name (NonLocalDef imp hif True) - other -> name +-- Look in global env only +lookup_global_occ global_env rdr_name + = case lookupRdrEnv global_env rdr_name of + Just [name] -> returnRn name + Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name + Nothing -> getModeRn `thenRn` \ mode -> + case mode of + -- Not found when processing source code; so fail + SourceMode -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + + -- Not found when processing an imported declaration, + -- so we create a new name for the purpose + InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name + -- lookupImplicitOccRn takes an RdrName representing an *original* name, and -- adds it to the occurrence pool so that it'll be loaded later. This is -- used when language constructs (such as monad comprehensions, overloaded literals, @@ -406,8 +396,8 @@ mungePrintUnqual (Unqual _) name -- The name cache should have the correct provenance, though. lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn (Qual mod occ hif) - = newImportedGlobalName mod occ hif `thenRn` \ name -> +lookupImplicitOccRn rdr_name + = newImportedGlobalFromRdrName rdr_name `thenRn` \ name -> addOccurrenceName name addImplicitOccRn :: Name -> RnMS s Name @@ -426,17 +416,17 @@ lookupFixity name Nothing -> returnRn (Fixity 9 InfixL) -- Default case \end{code} -mkPrintUnqualFn returns a function that takes a Name and tells whether +unQualInScope returns a function that takes a Name and tells whether its unqualified name is in scope. This is put as a boolean flag in the Name's provenance to guide whether or not to print the name qualified in error messages. \begin{code} -mkPrintUnqualFn :: GlobalRdrEnv -> Name -> Bool -mkPrintUnqualFn env +unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope env = lookup where - lookup name = case lookupRdrEnv env (Unqual (nameOccName name)) of + lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of Just [name'] -> name == name' other -> False \end{code} @@ -457,27 +447,6 @@ plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) =============== NameEnv ================ \begin{code} --- Look in global env only -lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name) -lookupGlobalNameRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - lookup_global global_env rdr_name - --- Look in both local and global env -lookupNameRn :: RdrName -> RnMS s (Maybe Name) -lookupNameRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - case lookupRdrEnv local_env rdr_name of - Just name -> returnRn (Just name) - Nothing -> lookup_global global_env rdr_name - -lookup_global global_env rdr_name - = case lookupRdrEnv global_env rdr_name of - Just [name] -> returnRn (Just name) - Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn (Just name) - Nothing -> returnRn Nothing - plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 @@ -505,10 +474,10 @@ combine_globals ns_old ns_new -- ns_new is often short -- 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 + (LocalDef _ _, _ ) -> True + (NonLocalDef (UserImport _ _ True) _, _ ) -> True + (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True + other -> False no_conflict :: Name -> Name -> Bool no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False @@ -542,18 +511,16 @@ mkExportAvails mod_name unqual_imp name_env avails -- we delete f from avails unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = [ avail' | avail <- avails - , let avail' = prune avail - , case avail' of - NotAvailable -> False - _ -> True - ] + | otherwise = mapMaybe prune avails - prune (Avail n) | unqual_in_scope n = Avail n - prune (Avail n) | otherwise = NotAvailable - prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns) + prune (Avail n) | unqual_in_scope n = Just (Avail n) + prune (Avail n) | otherwise = Nothing + prune (AvailTC n ns) | null uqs = Nothing + | otherwise = Just (AvailTC n uqs) + where + uqs = filter unqual_in_scope ns - unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env + unqual_in_scope n = unQualInScope name_env n entity_avail_env = listToUFM [ (name,avail) | avail <- avails, name <- availNames avail] @@ -569,8 +536,6 @@ plusExportAvails (m1, e1) (m2, e2) \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) -plusAvail a NotAvailable = a -plusAvail NotAvailable a = a -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) @@ -587,22 +552,17 @@ availName (Avail n) = n availName (AvailTC n _) = n availNames :: AvailInfo -> [Name] -availNames NotAvailable = [] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available - -> AvailInfo -- Resulting available; - -- NotAvailable if (any of the) wanted stuff isn't there + -> Maybe AvailInfo -- Resulting available; + -- Nothing if (any of the) wanted stuff isn't there filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = -#ifdef DEBUG - pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ -#endif - NotAvailable + | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) + | otherwise = Nothing where is_wanted name = nameOccName name `elem` wanted_occs sub_names_ok = all (`elem` avail_occs) wanted_occs @@ -610,11 +570,12 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) wanted_occs = map rdrNameOcc (want:wants) filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - AvailTC n [n] -filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail + Just (AvailTC n [n]) + +filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms -filterAvail (IEVar _) avail@(Avail n) = avail -filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) +filterAvail (IEVar _) avail@(Avail n) = Just avail +filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) where wanted n = nameOccName n == occ occ = rdrNameOcc v @@ -622,10 +583,9 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) -- import A( op ) -- where op is a class operation +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail -#ifdef DEBUG -filterAvail ie avail = pprPanic "filterAvail" (ppr ie $$ pprAvail avail) -#endif +filterAvail ie avail = Nothing -- In interfaces, pprAvail gets given the OccName of the "host" thing @@ -635,7 +595,6 @@ pprAvail avail = getPprStyle $ \ sty -> else ppr_avail ppr avail -ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") ppr_avail pp_name (AvailTC n ns) = hsep [ pp_name n, parens $ hsep $ punctuate comma $ @@ -662,11 +621,13 @@ unitFV :: Name -> FreeVars emptyFVs :: FreeVars plusFVs :: [FreeVars] -> FreeVars -plusFV = unionNameSets -addOneFV = addOneToNameSet -unitFV = unitNameSet emptyFVs = emptyNameSet plusFVs = unionManyNameSets +plusFV = unionNameSets + +-- No point in adding implicitly imported names to the free-var set +addOneFV s n = addOneToNameSet s n +unitFV n = unitNameSet n \end{code} @@ -678,68 +639,69 @@ plusFVs = unionManyNameSets \begin{code} -warnUnusedBinds, warnUnusedMatches :: [Name] -> RnM s d () - -warnUnusedTopNames ns - | not opt_WarnUnusedBinds && not opt_WarnUnusedImports - = returnRn () -- Don't force ns unless necessary - -warnUnusedTopNames (n:ns) - | is_local && opt_WarnUnusedBinds = warnUnusedNames False{-include name's provenance-} ns - | not is_local && opt_WarnUnusedImports = warnUnusedNames False ns - where - is_local = isLocallyDefined n +warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM s d () -warnUnusedTopName other = returnRn () +warnUnusedTopNames names + | not opt_WarnUnusedBinds && not opt_WarnUnusedImports = returnRn () -- Don't force ns unless necessary + | otherwise = warnUnusedBinds names -warnUnusedBinds ns +warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedNames False ns + | otherwise = warnUnusedBinds ns -{- - Haskell 98 encourages compilers to suppress warnings about - unused names in a pattern if they start with "_". Which - we do here. - - Note: omit the inclusion of the names' provenance in the - generated warning -- it's already given in the header - of the warning (+ the local names we've been given have - a provenance that's ultra low in content.) - --} warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedNames True (filter (not.isAnonOcc.getOccName) names) + | opt_WarnUnusedMatches = warnUnusedGroup names | otherwise = returnRn () -warnUnusedNames :: Bool{-display provenance-} -> [Name] -> RnM s d () -warnUnusedNames _ [] - = returnRn () +------------------------- -warnUnusedNames short_msg names - = addWarnRn $ - sep [text "The following names are unused:", - nest 4 ((if short_msg then hsep else vcat) (map pp names))] +warnUnusedBinds :: [Name] -> RnM s d () +warnUnusedBinds names + = mapRn warnUnusedGroup groups `thenRn_` + returnRn () where - pp n - | short_msg = ppr n - | otherwise = ppr n <> comma <+> pprNameProvenance n - -addNameClashErrRn rdr_name names -{- NO LONGER NEEDED WITH LAZY NAME-CLASH REPORTING - | isClassDataConRdrName rdr_name - -- Nasty hack to prevent error messages complain about conflicts for ":C", - -- where "C" is a class. There'll be a message about C, and :C isn't - -- the programmer's business. There may be a better way to filter this - -- out, but I couldn't get up the energy to find it. + -- Group by provenance + groups = equivClasses cmp names + name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2 + + cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT + cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 + cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) + (NonLocalDef (UserImport m2 loc2 _) _) = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) + cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT + -- In-scope NonLocalDefs must have UserImport info on them + +------------------------- + +warnUnusedGroup :: [Name] -> RnM s d () +warnUnusedGroup [] = returnRn () +warnUnusedGroup names + | is_local && not opt_WarnUnusedBinds = returnRn () + | not is_local && not opt_WarnUnusedImports = returnRn () | otherwise --} + = pushSrcLocRn def_loc $ + addWarnRn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr names)))] + where + name1 = head names + (is_local, def_loc, msg) + = case getNameProvenance name1 of + LocalDef loc _ -> (True, loc, text "Defined but not used") + NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> + text "but but not used") + other -> (False, getSrcLoc name1, text "Strangely defined but not used") +\end{code} +\begin{code} +addNameClashErrRn rdr_name (name1:names) = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to:") <+> vcat (map mk_ref names)]) + ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where - mk_ref name = ppr name <> colon <+> pprNameProvenance name + msg1 = ptext SLIT("either") <+> mk_ref name1 + msgs = [ptext SLIT(" or") <+> mk_ref name | name <- names] + mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) @@ -765,8 +727,8 @@ qualNameErr descriptor (name,loc) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (hsep [ptext SLIT("Conflicting definitions for"), - quotes (ppr name), - ptext SLIT("in"), descriptor]) + addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + $$ + (ptext SLIT("in") <+> descriptor)) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 6a050db482..d9643ad338 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -26,7 +26,7 @@ import RnHsSyn import RnMonad import RnEnv import CmdLineOpts ( opt_GlasgowExts ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..) ) import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, @@ -256,12 +256,7 @@ grubby_seqNameSet ns result | isNullUFM ns = result | otherwise = result \end{code} -Variables. We look up the variable and return the resulting name. The -interesting question is what the free-variable set should be. We -don't want to return imported or prelude things as free vars. So we -look at the Name returned from the lookup, and make it part of the -free-var set iff if it's a LocallyDefined Name. -\end{itemize} +Variables. We look up the variable and return the resulting name. \begin{code} rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) @@ -274,13 +269,11 @@ rnExpr (HsVar v) returnRn (expr, emptyUniqSet) else -- The normal case - returnRn (HsVar name, if isLocallyDefined name - then unitNameSet name - else emptyUniqSet) + returnRn (HsVar name, unitFV name) rnExpr (HsLit lit) = litOccurrence lit `thenRn_` - returnRn (HsLit lit, emptyNameSet) + returnRn (HsLit lit, emptyFVs) rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> @@ -437,7 +430,7 @@ rnRbinds str rbinds rn_rbind (field, expr, pun) = lookupGlobalOccRn field `thenRn` \ fieldname -> rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn ((fieldname, expr', pun), fvExpr) + returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname) rnRpats rpats = mapRn field_dup_err dup_fields `thenRn_` @@ -451,7 +444,7 @@ rnRpats rpats rn_rpat (field, pat, pun) = lookupGlobalOccRn field `thenRn` \ fieldname -> rnPat pat `thenRn` \ (pat', fvs) -> - returnRn ((fieldname, pat', pun), fvs) + returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname) \end{code} %************************************************************************ @@ -476,7 +469,7 @@ rnStmts :: RnExprTy s -> RnMS s ([RenamedStmt], FreeVars) rnStmts rn_expr [] - = returnRn ([], emptyNameSet) + = returnRn ([], emptyFVs) rnStmts rn_expr (stmt:stmts) = rnStmt rn_expr stmt $ \ stmt' -> @@ -745,18 +738,14 @@ litOccurrence (HsLitLit _) \begin{code} mkAssertExpr :: RnMS s RenamedHsExpr mkAssertExpr = - newImportedGlobalName mod occ HiFile `thenRn` \ name -> - addOccurrenceName name `thenRn_` - getSrcLocRn `thenRn` \ sloc -> + newImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name -> + addOccurrenceName name `thenRn_` + getSrcLocRn `thenRn` \ sloc -> let expr = HsApp (HsVar name) (HsLit (HsString (_PK_ (showSDoc (ppr sloc))))) in returnRn expr - - where - mod = rdrNameModule assertErr_RDR - occ = rdrNameOcc assertErr_RDR \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 543866a795..0407764715 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -27,12 +27,12 @@ import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), FixitySig(..), hsDeclName, countTyClDecls, isDataDecl, nonFixitySigs ) -import BasicTypes ( Version, NewOrData(..), IfaceFlavour(..) ) +import BasicTypes ( Version, NewOrData(..) ) import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, - RdrName(..), rdrNameOcc ) -import RnEnv ( newImportedGlobalName, addImplicitOccsRn, pprAvail, - availName, availNames, addAvailToNameSet, ifaceFlavour +import RnEnv ( newImportedGlobalName, newImportedGlobalFromRdrName, + addImplicitOccsRn, pprAvail, + availName, availNames, addAvailToNameSet ) import RnSource ( rnHsSigType ) import RnMonad @@ -43,11 +43,15 @@ import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, lookupFM, addToFM, addToFM_C, addListToFM, fmToList ) -import Name ( Name {-instance NamedThing-}, OccName, +import Name ( Name {-instance NamedThing-}, nameModule, moduleString, pprModule, isLocallyDefined, isWiredInName, maybeWiredInTyConName, pprModule, maybeWiredInIdName, nameUnique, NamedThing(..) ) +import OccName ( Module, mkBootModule, + moduleIfaceFlavour, bootFlavour, hiFile + ) +import RdrName ( RdrName, rdrNameOcc ) import NameSet import Id ( idType, isDataConId_maybe ) import DataCon ( dataConTyCon, dataConType ) @@ -161,31 +165,34 @@ count_decls decls \begin{code} loadHomeInterface :: SDoc -> Name -> RnMG Ifaces loadHomeInterface doc_str name - = loadInterface doc_str (nameModule name) (ifaceFlavour name) + = loadInterface doc_str (nameModule name) -loadInterface :: SDoc -> Module -> IfaceFlavour -> RnMG Ifaces -loadInterface doc_str load_mod as_source +loadInterface :: SDoc -> Module -> RnMG Ifaces +loadInterface doc_str load_mod = getIfacesRn `thenRn` \ ifaces -> let + new_hif = moduleIfaceFlavour load_mod this_mod = iMod ifaces mod_map = iModMap ifaces (insts, tycls_names) = iDefInsts ifaces in -- CHECK WHETHER WE HAVE IT ALREADY case lookupFM mod_map load_mod of { - Just (hif, _, _) | hif `as_good_as` as_source - -> -- Already in the cache; don't re-read it - returnRn ifaces ; + Just (existing_hif, _, _) + | bootFlavour new_hif || not (bootFlavour existing_hif) + -> -- Already in the cache, and new version is no better than old, + -- so don't re-read it + returnRn ifaces ; other -> -- READ THE MODULE IN - findAndReadIface doc_str load_mod as_source `thenRn` \ read_result -> + findAndReadIface doc_str load_mod `thenRn` \ read_result -> case read_result of { -- Check for not found Nothing -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again let - new_mod_map = addToFM mod_map load_mod (HiFile, 0, []) + new_mod_map = addToFM mod_map load_mod (hiFile, 0, []) new_ifaces = ifaces { iModMap = new_mod_map } in setIfacesRn new_ifaces `thenRn_` @@ -195,18 +202,19 @@ loadInterface doc_str load_mod as_source Just (ParsedIface _ mod_vers usages exports rd_inst_mods rd_decls rd_insts) -> -- LOAD IT INTO Ifaces + -- First set the module + setModuleRn load_mod $ + -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) - foldlRn (loadDecl load_mod as_source) - (iDecls ifaces) rd_decls `thenRn` \ new_decls -> - foldlRn (loadFixDecl load_mod as_source) - (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> - mapRn loadExport exports `thenRn` \ avails_s -> - foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts -> + foldlRn loadDecl (iDecls ifaces) rd_decls `thenRn` \ new_decls -> + foldlRn loadFixDecl (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> + mapRn loadExport exports `thenRn` \ avails_s -> + foldlRn loadInstDecl insts rd_insts `thenRn` \ new_insts -> let - mod_details = (as_source, mod_vers, concat avails_s) + mod_details = (new_hif, mod_vers, concat avails_s) -- Exclude this module from the "special-inst" modules new_inst_mods = iInstMods ifaces `unionLists` (filter (/= this_mod) rd_inst_mods) @@ -221,16 +229,11 @@ loadInterface doc_str load_mod as_source returnRn new_ifaces }} -as_good_as HiFile any = True -as_good_as any HiBootFile = True -as_good_as _ _ = False - - loadExport :: ExportItem -> RnMG [AvailInfo] -loadExport (mod, hif, entities) +loadExport (mod, entities) = mapRn load_entity entities where - new_name occ = newImportedGlobalName mod occ hif + new_name occ = newImportedGlobalName mod occ load_entity (Avail occ) = new_name occ `thenRn` \ name -> @@ -241,28 +244,32 @@ loadExport (mod, hif, entities) returnRn (AvailTC name names) -loadFixDecl :: Module -> IfaceFlavour -> FixityEnv +loadFixDecl :: FixityEnv -> (Version, RdrNameHsDecl) -> RnMG FixityEnv -loadFixDecl mod as_source fixity_env (version, FixD (FixitySig rdr_name fixity loc)) +loadFixDecl fixity_env (version, FixD (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 - new_implicit_name mod as_source rdr_name `thenRn` \ name -> + newImportedGlobalFromRdrName 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 as_source fixity_env other_decl = returnRn fixity_env +loadFixDecl fixity_env other_decl = returnRn fixity_env -loadDecl :: Module -> IfaceFlavour -> DeclsMap +loadDecl :: DeclsMap -> (Version, RdrNameHsDecl) -> RnMG DeclsMap -loadDecl mod as_source decls_map (version, decl) - = getDeclBinders new_name decl `thenRn` \ avail -> +loadDecl decls_map (version, decl) + = getDeclBinders new_name decl `thenRn` \ maybe_avail -> + case maybe_avail of { + Nothing -> returnRn decls_map; -- No bindings + Just avail -> + getDeclSysBinders new_name decl `thenRn` \ sys_bndrs -> let main_name = availName avail @@ -274,8 +281,9 @@ loadDecl mod as_source decls_map (version, decl) addToNameEnv decls_map name stuff in returnRn new_decls_map + } where - new_name rdr_name loc = new_implicit_name mod as_source rdr_name + new_name rdr_name loc = newImportedGlobalFromRdrName rdr_name {- If a signature decl is being loaded, and optIgnoreIfacePragmas is on, we toss away unfolding information. @@ -287,25 +295,21 @@ loadDecl mod as_source decls_map (version, decl) its interface file. Hence, B is recompiled, maybe changing its interface file, which will the unfolding info used in A to become invalid. Simple way out is to just ignore unfolding info. + + [Jan 99: I junked the second test above. If we're importing from an hi-boot + file there isn't going to *be* any pragma info. Maybe the above comment + dates from a time where we picked up a .hi file first if it existed?] -} decl' = case decl of - SigD (IfaceSig name tp ls loc) | from_hi_boot || opt_IgnoreIfacePragmas -> + SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas -> SigD (IfaceSig name tp [] loc) _ -> decl - from_hi_boot = case as_source of - HiBootFile -> True - other -> False - -new_implicit_name mod as_source rdr_name - = newImportedGlobalName mod (rdrNameOcc rdr_name) as_source - -loadInstDecl :: Module - -> Bag IfaceInst +loadInstDecl :: Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst) -loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) +loadInstDecl insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) = -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then @@ -323,9 +327,10 @@ loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_lo in -- We find the gates by renaming the instance type with in a -- and returning the free variables of the type - initRnMS emptyRnEnv mod_name vanillaInterfaceMode ( + initRnMS emptyRnEnv vanillaInterfaceMode ( discardOccurrencesRn (rnHsSigType (text "an instance decl") munged_inst_ty) ) `thenRn` \ (_, gate_names) -> + getModuleRn `thenRn` \ mod_name -> returnRn (((mod_name, decl), gate_names) `consBag` insts) vanillaInterfaceMode = InterfaceMode Compulsory @@ -341,7 +346,7 @@ vanillaInterfaceMode = InterfaceMode Compulsory \begin{code} checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile checkUpToDate mod_name - = findAndReadIface doc_str mod_name HiFile `thenRn` \ read_result -> + = findAndReadIface doc_str mod_name `thenRn` \ read_result -> -- CHECK WHETHER WE HAVE IT ALREADY case read_result of @@ -359,8 +364,8 @@ checkUpToDate mod_name checkModUsage [] = returnRn True -- Yes! Everything is up to date! -checkModUsage ((mod, hif, old_mod_vers, whats_imported) : rest) - = loadInterface doc_str mod hif `thenRn` \ ifaces -> +checkModUsage ((mod, old_mod_vers, whats_imported) : rest) + = loadInterface doc_str mod `thenRn` \ ifaces -> let maybe_new_mod_vers = lookupFM (iModMap ifaces) mod Just (_, new_mod_vers, _) = maybe_new_mod_vers @@ -406,7 +411,7 @@ checkEntityUsage mod decls [] = returnRn True -- Yes! All up to date! checkEntityUsage mod decls ((occ_name,old_vers) : rest) - = newImportedGlobalName mod occ_name HiFile `thenRn` \ name -> + = newImportedGlobalName mod occ_name `thenRn` \ name -> case lookupNameEnv decls name of Nothing -> -- We used it before, but it ain't there now @@ -432,7 +437,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -importDecl :: Occurrence -> RnSMode -> RnMG (Maybe RdrNameHsDecl) +importDecl :: Occurrence -> RnMode -> RnMG (Maybe RdrNameHsDecl) -- Returns Nothing for a wired-in or already-slurped decl importDecl (name, loc) mode @@ -458,7 +463,7 @@ importDecl (name, loc) mode \end{code} \begin{code} -getNonWiredInDecl :: Name -> SrcLoc -> RnSMode -> RnMG (Maybe RdrNameHsDecl) +getNonWiredInDecl :: Name -> SrcLoc -> RnMode -> RnMG (Maybe RdrNameHsDecl) getNonWiredInDecl needed_name loc mode = traceRn doc_str `thenRn_` loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> @@ -506,8 +511,9 @@ that we know just what instances to bring into scope. \begin{code} getWiredInDecl name mode - = initRnMS emptyRnEnv mod_name new_mode - get_wired `thenRn` \ avail -> + = setModuleRn mod_name ( + initRnMS emptyRnEnv new_mode get_wired + ) `thenRn` \ avail -> recordSlurp Nothing necessity avail `thenRn_` -- Force in the home module in case it has instance decls for @@ -602,9 +608,9 @@ get_wired_tycon tycon %********************************************************* \begin{code} -getInterfaceExports :: Module -> IfaceFlavour -> RnMG Avails -getInterfaceExports mod as_source - = loadInterface doc_str mod as_source `thenRn` \ ifaces -> +getInterfaceExports :: Module -> RnMG Avails +getInterfaceExports mod + = loadInterface doc_str mod `thenRn` \ ifaces -> case lookupFM (iModMap ifaces) mod of Nothing -> -- Not there; it must be that the interface file wasn't found; -- the error will have been reported already. @@ -746,7 +752,7 @@ getImportedInstDecls setIfacesRn new_ifaces `thenRn_` returnRn un_gated_insts where - load_it mod = loadInterface (doc_str mod) mod HiFile + load_it mod = loadInterface (doc_str mod) mod doc_str mod = sep [pprModule mod, ptext SLIT("is a special-instance module")] @@ -828,7 +834,7 @@ getImportVersions this_mod exports mk_version_info (mod, local_versions) = case lookupFM mod_map mod of - Just (hif, version, _) -> (mod, hif, version, local_versions) + Just (hif, version, _) -> (mod, version, local_versions) in returnRn (map mk_version_info (fmToList mv_map)) where @@ -908,18 +914,18 @@ are handled by the sourc-code specific stuff in RnNames. \begin{code} getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function -> RdrNameHsDecl - -> RnMG AvailInfo + -> RnMG (Maybe AvailInfo) 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 (AvailTC tycon_name (tycon_name : nub sub_names)) + returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names))) -- The "nub" is because getConFieldNames can legitimately return duplicates, -- when a record declaration has the same field in multiple constructors getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> - returnRn (AvailTC tycon_name [tycon_name]) + returnRn (Just (AvailTC tycon_name [tycon_name])) getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc)) = new_name cname src_loc `thenRn` \ class_name -> @@ -931,16 +937,16 @@ getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc in mapRn (getClassOpNames new_name) nonfix_sigs `thenRn` \ sub_names -> - returnRn (AvailTC class_name (class_name : sub_names)) + returnRn (Just (AvailTC class_name (class_name : sub_names))) getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) = new_name var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name) + returnRn (Just (Avail var_name)) -getDeclBinders new_name (FixD _) = returnRn NotAvailable -getDeclBinders new_name (ForD _) = returnRn NotAvailable -getDeclBinders new_name (DefD _) = returnRn NotAvailable -getDeclBinders new_name (InstD _) = returnRn NotAvailable +getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (ForD _) = returnRn Nothing +getDeclBinders new_name (DefD _) = returnRn Nothing +getDeclBinders new_name (InstD _) = returnRn Nothing ---------------- getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest) @@ -968,7 +974,7 @@ getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc @getDeclSysBinders@ gets the implicit binders introduced by a decl. A the moment that's just the tycon and datacon that come with a class decl. They aren'te returned by getDeclBinders because they aren't in scope; -but they should be put into the DeclsMap of this module. +but they *should* be put into the DeclsMap of this module. \begin{code} getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc)) @@ -987,17 +993,16 @@ getDeclSysBinders new_name other_decl %********************************************************* \begin{code} -findAndReadIface :: SDoc -> Module - -> IfaceFlavour - -> RnMG (Maybe ParsedIface) +findAndReadIface :: SDoc -> Module -> RnMG (Maybe ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -findAndReadIface doc_str mod_name as_source + +findAndReadIface doc_str mod_name = traceRn trace_msg `thenRn_` -- we keep two maps for interface files, -- one for 'normal' ones, the other for .hi-boot files, -- hence the need to signal which kind we're interested. - getModuleHiMap as_source `thenRn` \ himap -> + getModuleHiMap from_hi_boot `thenRn` \ himap -> case (lookupFM himap (moduleString mod_name)) of -- Found the file Just fpath -> readIface fpath @@ -1005,17 +1010,17 @@ findAndReadIface doc_str mod_name as_source -- decls for packCString# and friends; they are 'thin-air' Ids -- (see PrelInfo.lhs). So if we don't find the HiFile we quietly -- look for a .hi-boot file instead, and use that - Nothing | thinAirLoop mod_name as_source - -> findAndReadIface doc_str mod_name HiBootFile + Nothing | not from_hi_boot && mod_name `elem` thinAirModules + -> findAndReadIface doc_str (mkBootModule mod_name) | otherwise -> traceRn (ptext SLIT("...failed")) `thenRn_` returnRn Nothing where - thinAirLoop mod_name HiFile = mod_name `elem` thinAirModules - thinAirLoop mod_name hif = False + hif = moduleIfaceFlavour mod_name + from_hi_boot = bootFlavour hif trace_msg = sep [hsep [ptext SLIT("Reading"), - case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty}, + if from_hi_boot then ptext SLIT("[boot]") else empty, ptext SLIT("interface for"), pprModule mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 07f2f5bb0d..feb0309864 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -27,16 +27,16 @@ import List ( intersperse ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) -import BasicTypes ( Version, IfaceFlavour(..) ) +import BasicTypes ( Version ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message ) -import Name ( Module, Name, OccName, PrintUnqualified, - isLocallyDefinedName, pprModule, - modAndOcc, NamedThing(..) +import Name ( Module, Name, OccName, NamedThing(..), IfaceFlavour, + isLocallyDefinedName, nameModule, nameOccName ) import NameSet +import RdrName ( RdrName ) import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) @@ -103,11 +103,14 @@ type RnMG r = RnM RealWorld GDown r -- Getting global names etc type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn of this -- Common part -data RnDown s = RnDown - SrcLoc - (SSTRef s RnNameSupply) - (SSTRef s (Bag WarnMsg, Bag ErrMsg)) - (SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp +data RnDown s = RnDown { + rn_loc :: SrcLoc, + rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing + rn_ns :: SSTRef s RnNameSupply, + rn_errs :: SSTRef s (Bag WarnMsg, Bag ErrMsg), + rn_occs :: SSTRef s ([Occurrence],[Occurrence]), -- Occurrences: compulsory and optional resp + rn_mod :: Module + } type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site @@ -116,27 +119,27 @@ data Necessity = Compulsory | Optional -- We *must* find definitions for -- for optional ones. -- For getting global names -data GDown = GDown - ModuleHiMap -- for .hi files - ModuleHiMap -- for .hi-boot files - (SSTRWRef Ifaces) +data GDown = GDown { + rn_hi_map :: ModuleHiMap, -- for .hi files + rn_hiboot_map :: ModuleHiMap, -- for .hi-boot files + rn_ifaces :: SSTRWRef Ifaces + } -- For renaming source code -data SDown s = SDown - RnEnv -- Global envt; the fixity component gets extended +data SDown s = SDown { + rn_mode :: RnMode, + rn_genv :: RnEnv, -- Global envt; the fixity component gets extended -- with local fixity decls - LocalRdrEnv -- Local name envt + rn_lenv :: LocalRdrEnv -- Local name envt -- Does *not* includes global name envt; may shadow it -- Includes both ordinary variables and type variables; -- they are kept distinct because tyvar have a different -- occurrence contructor (Name.TvOcc) -- We still need the unsullied global name env so that -- we can look up record field names - Module - RnSMode + } - -data RnSMode = SourceMode -- Renaming source code +data RnMode = SourceMode -- Renaming source code | InterfaceMode -- Renaming interface declarations. Necessity -- The "necessity" -- flag says free variables *must* be found and slurped @@ -240,8 +243,7 @@ type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" e -- Maps a Name to the AvailInfo that contains it -data GenAvailInfo name = NotAvailable - | Avail name -- An ordinary identifier +data GenAvailInfo name = Avail name -- An ordinary identifier | AvailTC name -- The name of the type or class [name] -- The available pieces of type/class. NB: If the type or -- class is itself to be in scope, it must be in this list. @@ -255,10 +257,10 @@ type RdrAvailInfo = GenAvailInfo OccName =================================================== \begin{code} -type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo]) +type ExportItem = (Module, [RdrAvailInfo]) type VersionInfo name = [ImportVersion name] -type ImportVersion name = (Module, IfaceFlavour, Version, WhatsImported name) +type ImportVersion name = (Module, Version, WhatsImported name) data WhatsImported name = Everything | Specifically [LocalVersion name] -- List guaranteed non-empty @@ -287,7 +289,7 @@ type RdrNamePragma = () -- Fudge for now ------------------- data Ifaces = Ifaces { - iMod :: Module, -- Name of this module + iMod :: Module, -- Name of the module being compiled iModMap :: FiniteMap Module (IfaceFlavour, -- Exports Version, @@ -353,8 +355,10 @@ initRn mod us dirs loc do_rn = do occs_var <- sstToIO (newMutVarSST initOccs) (himap, hibmap) <- mkModuleHiMaps dirs let - rn_down = RnDown loc names_var errs_var occs_var - g_down = GDown himap hibmap iface_var + rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var, + rn_errs = errs_var, rn_occs = occs_var, + rn_mod = mod } + g_down = GDown { rn_hi_map = himap, rn_hiboot_map = hibmap, rn_ifaces = iface_var } -- do the business res <- sstToIO (do_rn rn_down g_down) @@ -364,10 +368,10 @@ initRn mod us dirs loc do_rn = do return (res, errs, warns) -initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r -initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down +initRnMS :: RnEnv -> RnMode -> RnMS RealWorld r -> RnMG r +initRnMS rn_env mode m rn_down g_down = let - s_down = SDown rn_env emptyRdrEnv mod_name mode + s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, rn_mode = mode } in m rn_down s_down @@ -385,7 +389,9 @@ emptyIfaces mod = Ifaces { iMod = mod, } builtins :: FiniteMap (Module,OccName) Name -builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) +builtins = bagToFM $ + mapBag (\ name -> ((nameModule name, nameOccName name), name)) + builtinNames -- Initial value for the occurrence pool. initOccs :: ([Occurrence],[Occurrence]) -- Compulsory and optional respectively @@ -497,8 +503,11 @@ renameSourceCode mod_name name_supply m newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> newMutVarSST ([],[]) `thenSST` \ occs_var -> let - rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var - s_down = SDown emptyRnEnv emptyRdrEnv mod_name (InterfaceMode Compulsory) + rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, + rn_errs = errs_var, rn_occs = occs_var, + rn_mod = mod_name } + s_down = SDown { rn_mode = InterfaceMode Compulsory, + rn_genv = emptyRnEnv, rn_lenv = emptyRdrEnv } in m rn_down s_down `thenSST` \ result -> @@ -508,7 +517,7 @@ renameSourceCode mod_name name_supply m pprTrace "Urk! renameSourceCode found errors" (display errs) #ifdef DEBUG else if not (isEmptyBag warns) then - pprTrace "Urk! renameSourceCode found warnings" (display warns) + pprTrace "Note: renameSourceCode found warnings" (display warns) #endif else id) $ @@ -528,7 +537,7 @@ thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b] -mapMaybeRn :: (a -> RnM s d b) -> b -> Maybe a -> RnM s d b +mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b] sequenceRn :: [RnM s d a] -> RnM s d [a] foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c]) @@ -570,8 +579,12 @@ mapAndUnzip3Rn f (x:xs) mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> returnRn (r1:rs1, r2:rs2, r3:rs3) -mapMaybeRn f def Nothing = returnRn def -mapMaybeRn f def (Just v) = f v +mapMaybeRn f [] = returnRn [] +mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> + mapMaybeRn f xs `thenRn` \ rs -> + case maybe_r of + Nothing -> returnRn rs + Just r -> returnRn (r:rs) \end{code} @@ -587,7 +600,7 @@ mapMaybeRn f def (Just v) = f v \begin{code} failWithRn :: a -> Message -> RnM s d a -failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down +failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` returnSST res @@ -595,7 +608,7 @@ failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down err = addShortErrLocLine loc msg warnWithRn :: a -> Message -> RnM s d a -warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down +warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` returnSST res @@ -617,7 +630,7 @@ addWarnRn :: Message -> RnM s d () addWarnRn warn = warnWithRn () warn checkErrsRn :: RnM s d Bool -- True <=> no errors so far -checkErrsRn (RnDown loc names_var errs_var occs_var) l_down +checkErrsRn (RnDown {rn_errs = errs_var}) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> returnSST (isEmptyBag errs) \end{code} @@ -627,28 +640,28 @@ checkErrsRn (RnDown loc names_var errs_var occs_var) l_down \begin{code} pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a -pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down - = m (RnDown loc' names_var errs_var occs_var) l_down +pushSrcLocRn loc' m down l_down + = m (down {rn_loc = loc'}) l_down getSrcLocRn :: RnM s d SrcLoc -getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down - = returnSST loc +getSrcLocRn down l_down + = returnSST (rn_loc down) \end{code} ================ Name supply ===================== \begin{code} getNameSupplyRn :: RnM s d RnNameSupply -getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down - = readMutVarSST names_var +getNameSupplyRn rn_down l_down + = readMutVarSST (rn_ns rn_down) setNameSupplyRn :: RnNameSupply -> RnM s d () -setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down +setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down = writeMutVarSST names_var names' -- See comments with RnNameSupply above. newInstUniq :: (OccName, OccName) -> RnM s d Int -newInstUniq key (RnDown loc names_var errs_var occs_var) l_down +newInstUniq key (RnDown {rn_ns = names_var}) l_down = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> let uniq = case lookupFM mapInst key of @@ -687,8 +700,8 @@ but it seems simpler just to do all the compulsory ones first. \begin{code} addOccurrenceName :: Name -> RnMS s Name -- Same name returned as passed -addOccurrenceName name (RnDown loc names_var errs_var occs_var) - (SDown rn_env local_env mod_name mode) +addOccurrenceName name (RnDown {rn_loc = loc, rn_occs = occs_var}) + (SDown {rn_mode = mode}) | isLocallyDefinedName name || not_necessary necessity = returnSST name @@ -707,8 +720,8 @@ addOccurrenceName name (RnDown loc names_var errs_var occs_var) addOccurrenceNames :: [Name] -> RnMS s () -addOccurrenceNames names (RnDown loc names_var errs_var occs_var) - (SDown rn_env local_env mod_name mode) +addOccurrenceNames names (RnDown {rn_loc = loc, rn_occs = occs_var}) + (SDown {rn_mode = mode}) | not_necessary necessity = returnSST () @@ -729,8 +742,8 @@ addOccurrenceNames names (RnDown loc names_var errs_var occs_var) not_necessary Compulsory = False not_necessary Optional = opt_IgnoreIfacePragmas -popOccurrenceName :: RnSMode -> RnM s d (Maybe Occurrence) -popOccurrenceName mode (RnDown loc names_var errs_var occs_var) l_down +popOccurrenceName :: RnMode -> RnM s d (Maybe Occurrence) +popOccurrenceName mode (RnDown {rn_occs = occs_var}) l_down = readMutVarSST occs_var `thenSST` \ occs -> case (mode, occs) of -- Find a compulsory occurrence @@ -755,12 +768,33 @@ popOccurrenceName mode (RnDown loc names_var errs_var occs_var) l_down -- as occurrences. discardOccurrencesRn :: RnM s d a -> RnM s d a -discardOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down +discardOccurrencesRn enclosed_thing rn_down l_down = newMutVarSST ([],[]) `thenSST` \ new_occs_var -> - enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down + enclosed_thing (rn_down {rn_occs = new_occs_var}) l_down \end{code} +================ Module ===================== + +\begin{code} +getModuleRn :: RnM s d Module +getModuleRn (RnDown {rn_mod = mod_name}) l_down + = returnSST mod_name + +setModuleRn :: Module -> RnM s d a -> RnM s d a +setModuleRn new_mod enclosed_thing rn_down l_down + = enclosed_thing (rn_down {rn_mod = new_mod}) l_down +\end{code} + +\begin{code} +setOmitQualFn :: (Name -> Bool) -> RnM s d a -> RnM s d a +setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down + +getOmitQualFn :: RnM s d (Name -> Bool) +getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down + = returnSST omit_fn +\end{code} + %************************************************************************ %* * \subsection{Plumbing for rename-source part} @@ -771,46 +805,40 @@ discardOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_d \begin{code} getNameEnvs :: RnMS s (GlobalRdrEnv, LocalRdrEnv) -getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) +getNameEnvs rn_down (SDown {rn_genv = RnEnv global_env fixity_env, rn_lenv = local_env}) = returnSST (global_env, local_env) getLocalNameEnv :: RnMS s LocalRdrEnv -getLocalNameEnv rn_down (SDown rn_env local_env mod_name mode) +getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) = returnSST local_env setLocalNameEnv :: LocalRdrEnv -> RnMS s a -> RnMS s a -setLocalNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode) - = m rn_down (SDown rn_env local_env' mod_name mode) +setLocalNameEnv local_env' m rn_down l_down + = m rn_down (l_down {rn_lenv = local_env'}) getFixityEnv :: RnMS s FixityEnv -getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode) +getFixityEnv rn_down (SDown {rn_genv = RnEnv name_env fixity_env}) = returnSST fixity_env extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS s a -> RnMS s a extendFixityEnv fixes enclosed_scope - rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode) + rn_down l_down@(SDown {rn_genv = RnEnv name_env fixity_env}) = let new_fixity_env = extendNameEnv fixity_env fixes in - enclosed_scope rn_down (SDown (RnEnv name_env new_fixity_env) local_env mod_name mode) + enclosed_scope rn_down (l_down {rn_genv = RnEnv name_env new_fixity_env}) \end{code} -================ Module and Mode ===================== - -\begin{code} -getModuleRn :: RnMS s Module -getModuleRn rn_down (SDown rn_env local_env mod_name mode) - = returnSST mod_name -\end{code} +================ Mode ===================== \begin{code} -getModeRn :: RnMS s RnSMode -getModeRn rn_down (SDown rn_env local_env mod_name mode) +getModeRn :: RnMS s RnMode +getModeRn rn_down (SDown {rn_mode = mode}) = returnSST mode -setModeRn :: RnSMode -> RnMS s a -> RnMS s a -setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode) - = thing_inside rn_down (SDown rn_env local_env mod_name new_mode) +setModeRn :: RnMode -> RnMS s a -> RnMS s a +setModeRn new_mode thing_inside rn_down l_down + = thing_inside rn_down (l_down {rn_mode = new_mode}) \end{code} @@ -822,18 +850,17 @@ setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode) \begin{code} getIfacesRn :: RnMG Ifaces -getIfacesRn rn_down (GDown himap hibmap iface_var) +getIfacesRn rn_down (GDown {rn_ifaces = iface_var}) = readMutVarSST iface_var setIfacesRn :: Ifaces -> RnMG () -setIfacesRn ifaces rn_down (GDown himap hibmap iface_var) +setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var}) = writeMutVarSST iface_var ifaces -getModuleHiMap :: IfaceFlavour -> RnMG ModuleHiMap -getModuleHiMap as_source rn_down (GDown himap hibmap iface_var) - = case as_source of - HiBootFile -> returnSST hibmap - _ -> returnSST himap +getModuleHiMap :: Bool -> RnMG ModuleHiMap +getModuleHiMap want_hi_boot rn_down (GDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) + | want_hi_boot = returnSST hibmap + | otherwise = returnSST himap \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 2b91305d9b..a0dbf46b18 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -11,7 +11,7 @@ module RnNames ( #include "HsVersions.h" import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, - opt_SourceUnchanged + opt_SourceUnchanged, opt_WarnUnusedBinds ) import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..), TyClDecl(..), @@ -20,14 +20,12 @@ import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..), TyClDecl(..), FixitySig(..), Sig(..), collectTopBinders ) -import RdrHsSyn ( RdrName(..), RdrNameIE, RdrNameImportDecl, - RdrNameHsModule, RdrNameHsDecl, - rdrNameOcc, ieOcc +import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, + RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, getDeclBinders, getImportedFixities, recordSlurp, checkUpToDate, loadHomeInterface ) -import BasicTypes ( IfaceFlavour(..) ) import RnEnv import RnMonad @@ -36,7 +34,9 @@ import PrelMods import UniqFM ( lookupUFM ) import Bag ( bagToList ) import Maybes ( maybeToBool ) +import NameSet import Name +import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual ) import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable @@ -70,16 +70,17 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) fixRn (\ ~(rec_rn_env, _) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? - rec_unqual_fn = mkPrintUnqualFn rec_rn_env + rec_unqual_fn = unQualInScope rec_rn_env in + setOmitQualFn rec_unqual_fn $ + -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS - mapAndUnzipRn (importsFromImportDecl this_mod rec_unqual_fn) - all_imports `thenRn` \ (imp_gbl_envs, imp_avails_s) -> + mapAndUnzipRn importsFromImportDecl all_imports `thenRn` \ (imp_gbl_envs, imp_avails_s) -> -- COMBINE RESULTS -- We put the local env second, so that a local provenance @@ -147,13 +148,12 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) | otherwise = [ImportDecl pRELUDE False {- Not qualified -} - HiFile {- Not source imported -} Nothing {- No "as" -} Nothing {- No import list -} mod_loc] explicit_prelude_import - = not (null [ () | (ImportDecl mod qual _ _ _ _) <- imports, mod == pRELUDE ]) + = not (null [ () | (ImportDecl mod qual _ _ _) <- imports, mod == pRELUDE ]) \end{code} \begin{code} @@ -181,15 +181,13 @@ checkEarlyExit mod \end{code} \begin{code} -importsFromImportDecl :: Module -- The module being compiled - -> (Name -> Bool) -- True => print unqualified - -> RdrNameImportDecl +importsFromImportDecl :: RdrNameImportDecl -> RnMG (GlobalRdrEnv, ExportAvails) -importsFromImportDecl this_mod rec_unqual_fn (ImportDecl imp_mod qual_only as_source as_mod import_spec iloc) +importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc) = pushSrcLocRn iloc $ - getInterfaceExports imp_mod as_source `thenRn` \ avails -> + getInterfaceExports imp_mod `thenRn` \ avails -> if null avails then -- If there's an error in getInterfaceExports, (e.g. interface @@ -206,12 +204,6 @@ importsFromImportDecl this_mod rec_unqual_fn (ImportDecl imp_mod qual_only as_so home_modules = [name | avail <- filtered_avails, -- Doesn't take account of hiding, but that doesn't matter - -- Drop NotAvailables. - -- Happens if filterAvail finds something missing - case avail of - NotAvailable -> False - other -> True, - let name = availName avail, not (isLocallyDefined name || nameModule name == imp_mod) -- Don't try to load the module being compiled @@ -231,13 +223,8 @@ importsFromImportDecl this_mod rec_unqual_fn (ImportDecl imp_mod qual_only as_so -- (b) the print-unqualified field -- But don't fiddle with wired-in things or we get in a twist let - improve_prov name | isWiredInName name = name - | otherwise = setNameProvenance name (mk_new_prov name) - - is_explicit name = name `elemNameSet` explicits - mk_new_prov name = NonLocalDef (UserImport imp_mod iloc (is_explicit name)) - as_source - (rec_unqual_fn name) + improve_prov name = setNameImportReason name (UserImport imp_mod iloc (is_explicit name)) + is_explicit name = name `elemNameSet` explicits in qualifyImports imp_mod (not qual_only) -- Maybe want unqualified names @@ -301,10 +288,10 @@ getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) = returnRn [] getLocalDeclBinders new_name decl - = getDeclBinders new_name decl `thenRn` \ avail -> - case avail of - NotAvailable -> returnRn [] -- Instance decls and suchlike - other -> returnRn [avail] + = getDeclBinders new_name decl `thenRn` \ maybe_avail -> + case maybe_avail of + Nothing -> returnRn [] -- Instance decls and suchlike + Just avail -> returnRn [avail] binds_haskell_name (FoImport _) _ = True binds_haskell_name FoLabel _ = True @@ -328,9 +315,11 @@ fixitiesFromLocalDecls gbl_env decls fix_decl acc (FixitySig rdr_name fixity loc) = -- Check for fixity decl for something not declared case lookupRdrEnv gbl_env rdr_name of { - Nothing -> pushSrcLocRn loc $ - addWarnRn (unusedFixityDecl rdr_name fixity) `thenRn_` - returnRn acc ; + Nothing | opt_WarnUnusedBinds + -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) `thenRn_` + returnRn acc + | otherwise -> returnRn acc ; + Just (name:_) -> -- Check for duplicate fixity decl @@ -366,15 +355,18 @@ filterImports mod Nothing imports = returnRn (imports, [], emptyNameSet) filterImports mod (Just (want_hiding, import_items)) avails - = mapRn check_item import_items `thenRn` \ item_avails -> + = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits -> + let + (item_avails, explicits_s) = unzip avails_w_explicits + explicits = foldl addListToNameSet emptyNameSet explicits_s + in if want_hiding then -- All imported; item_avails to be hidden returnRn (avails, item_avails, emptyNameSet) else -- Just item_avails imported; nothing to be hidden - returnRn (item_avails, [], availsToNameSet item_avails) - + returnRn (item_avails, [], explicits) where import_fm :: FiniteMap OccName AvailInfo import_fm = listToFM [ (nameOccName name, avail) @@ -382,35 +374,44 @@ filterImports mod (Just (want_hiding, import_items)) avails name <- availNames avail] -- Even though availNames returns data constructors too, -- they won't make any difference because naked entities like T - -- in an import list map to TCOccs, not VarOccs. + -- in an import list map to TcOccs, not VarOccs. check_item item@(IEModuleContents _) = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn NotAvailable + returnRn Nothing check_item item | not (maybeToBool maybe_in_import_avails) || - (case filtered_avail of { NotAvailable -> True; other -> False }) + not (maybeToBool maybe_filtered_avail) = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn NotAvailable + returnRn Nothing | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_` - returnRn filtered_avail + returnRn (Just (filtered_avail, explicits)) - | otherwise = returnRn filtered_avail + | otherwise = returnRn (Just (filtered_avail, explicits)) where - maybe_in_import_avails = lookupFM import_fm (ieOcc item) + wanted_occ = rdrNameOcc (ieName item) + maybe_in_import_avails = lookupFM import_fm wanted_occ + Just avail = maybe_in_import_avails - filtered_avail = filterAvail item avail - dodgy_import = case (item, avail) of - (IEThingAll _, AvailTC _ [n]) -> True - -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - - other -> False + maybe_filtered_avail = filterAvail item avail + Just filtered_avail = maybe_filtered_avail + explicits | dot_dot = [availName filtered_avail] + | otherwise = availNames filtered_avail + + dot_dot = case item of + IEThingAll _ -> True + other -> False + + dodgy_import = case (item, avail) of + (IEThingAll _, AvailTC _ [n]) -> True + -- This occurs when you import T(..), but + -- only export T abstractly. The single [n] + -- in the AvailTC is the type or class itself + other -> False \end{code} @@ -469,16 +470,14 @@ qualifyImports this_mod unqual_imp as_mod hides | unqual_imp = env2 | otherwise = env1 where - env1 = addOneToGlobalRdrEnv env (Qual qual_mod occ err_hif) better_name - env2 = addOneToGlobalRdrEnv env1 (Unqual occ) better_name + env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name + env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name occ = nameOccName name better_name = improve_prov name del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names where - rdr_names = map (Unqual . nameOccName) (availNames avail) - -err_hif = error "qualifyImports: hif" -- Not needed in key to mapping + rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail) \end{code} @@ -585,7 +584,7 @@ exportsFromAvail this_mod (Just export_items) #endif | not enough_avail - = failWithRn acc (exportItemErr ie export_avail) + = failWithRn acc (exportItemErr ie) | otherwise -- Phew! It's OK! Now to check the occurrence stuff! = check_occs ie occs export_avail `thenRn` \ occs' -> @@ -595,10 +594,11 @@ exportsFromAvail this_mod (Just export_items) rdr_name = ieName ie maybe_in_scope = lookupFM global_name_env rdr_name Just (name:dup_names) = maybe_in_scope - maybe_avail = lookupUFM entity_avail_env name - Just avail = maybe_avail - export_avail = filterAvail ie avail - enough_avail = case export_avail of {NotAvailable -> False; other -> True} + maybe_avail = lookupUFM entity_avail_env name + Just avail = maybe_avail + maybe_export_avail = filterAvail ie avail + enough_avail = maybeToBool maybe_export_avail + Just export_avail = maybe_export_avail add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail @@ -646,13 +646,8 @@ dodgyImportWarn mod (IEThingAll tc) modExportErr mod = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModule mod)] -exportItemErr export_item NotAvailable - = sep [ ptext SLIT("Export item not in scope:"), quotes (ppr export_item)] - -exportItemErr export_item avail - = hang (ptext SLIT("Export item not fully in scope:")) - 4 (vcat [hsep [ptext SLIT("Wanted: "), ppr export_item], - hsep [ptext SLIT("Available:"), ppr (ieOcc export_item), pprAvail avail]]) +exportItemErr export_item + = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] exportClashErr occ_name ie1 ie2 = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2), diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 01091ca6a4..4be592ae35 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -13,7 +13,10 @@ import HsSyn import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsPragmas import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) -import RdrHsSyn +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc ) +import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, + extractHsTyVars + ) import RnHsSyn import HsCore @@ -21,22 +24,22 @@ import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, addImplicitOccRn, bindLocalsRn, - bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvRn, + bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, checkDupOrQualNames, checkDupNames, newLocallyDefinedGlobalName, newImportedGlobalName, newImportedGlobalFromRdrName, - ifaceFlavour, newDFunName, + newDFunName, FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV ) import RnMonad import Name ( Name, OccName, ExportFlag(..), Provenance(..), - nameOccName, NamedThing(..), isConOcc, + nameOccName, NamedThing(..), mkDefaultMethodOcc, mkDFunOcc ) import NameSet -import BasicTypes ( TopLevelFlag(..), IfaceFlavour(..) ) +import BasicTypes ( TopLevelFlag(..) ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) import Type ( funTyCon ) import FiniteMap ( elemFM ) @@ -82,8 +85,8 @@ rnSourceDecls decls -- 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 + go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> + go (fvs `plusFV` fvs') (d':ds') ds rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl rnIfaceDecl d @@ -153,7 +156,7 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragma returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc), cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs) where - data_doc = text "the data type declaration for" <+> ppr tycon + data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls rnDecl (TyClD (TySynonym name tyvars ty src_loc)) @@ -244,8 +247,8 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr (InterfaceMode _, Just _) -> -- Imported class that has a default method decl - newImportedGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name -> - addOccurrenceName dm_name `thenRn_` + newImportedGlobalName mod_name dm_occ `thenRn` \ dm_name -> + addOccurrenceName dm_name `thenRn_` returnRn (Just dm_name) other -> returnRn Nothing @@ -273,7 +276,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too in - extendTyVarEnvRn inst_tyvars $ + extendTyVarEnvFVRn inst_tyvars $ -- Rename the bindings -- NB meth_names can be qualified! @@ -282,7 +285,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) let binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds'))) in - renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags -> + renameSigs NotTopLevel True binders uprags `thenRn` \ (new_uprags, prag_fvs) -> mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name -> addOccurrenceName dfun_name `thenRn_` -- The dfun is not optional, because we use its version number @@ -290,7 +293,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- The typechecker checks that all the bindings are for the right class. returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc), - inst_fvs `plusFV` meth_fvs) + inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs) where meth_doc = text "the bindings in an instance declaration" meth_names = bagToList (collectMonoBinders mbinds) @@ -353,7 +356,7 @@ rnDerivs Nothing -- derivs not specified rnDerivs (Just ds) = mapRn rn_deriv ds `thenRn` \ derivs -> - returnRn (Just derivs, mkNameSet derivs) + returnRn (Just derivs, foldl addOneFV emptyFVs derivs) where rn_deriv clas = lookupOccRn clas `thenRn` \ clas_name -> @@ -437,7 +440,7 @@ rnBangTy doc (Unbanged ty) -- from interface files, which always print in prefix form checkConName name - = checkRn (isConOcc (rdrNameOcc name)) + = checkRn (isRdrDataCon name) (badDataCon name) \end{code} @@ -783,7 +786,7 @@ dupClassAssertWarn ctxt (assertion : dups) = sep [hsep [ptext SLIT("Duplicate class assertion"), quotes (pprClassAssertion assertion), ptext SLIT("in the context:")], - nest 4 (pprContext ctxt)] + nest 4 (pprContext ctxt <+> ptext SLIT("..."))] badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 015ea5a3dd..38297e6823 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -68,6 +68,7 @@ import Unique ( Unique, Uniquable(..), import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) import Util ( mapAccumL ) +import SrcLoc ( noSrcLoc ) import Bag import Maybes import IO ( hPutStr, stderr ) @@ -323,7 +324,8 @@ tidyNestedBndr env@(tidy_env, var_env) id = -- Non-top-level variables let -- Give the Id a fresh print-name, *and* rename its type - name' = mkLocalName (getUnique id) occ' + -- The SrcLoc isn't important now, though we could extract it from the Id + name' = mkLocalName (getUnique id) occ' noSrcLoc (tidy_env', occ') = tidyOccName tidy_env (getOccName id) ty' = tidyType env (idType id) id' = mkUserId name' ty' diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index a35a909abe..081393a6ac 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -35,7 +35,7 @@ import UniqSupply ( UniqSupply, UniqSM, initUs, thenUs, thenUs_, returnUs, getUniqueUs, getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs ) -import Name ( nameOccName ) +import Name ( nameOccName, mkSpecOcc, getSrcLoc ) import FiniteMap import Maybes ( MaybeErr(..), catMaybes ) import Bag @@ -1133,7 +1133,7 @@ newIdSM old_id new_ty = getUniqSM `thenSM` \ uniq -> let -- Give the new Id a similar occurrence name to the old one - new_id = mkUserLocal (nameOccName name) uniq new_ty + new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name) name = idName old_id in returnSM new_id diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index f568f4f43e..63d0433e49 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -49,7 +49,7 @@ import Class ( classInstEnv, import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import VarSet ( elemVarSet ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( OccName, Name, mkDictOcc, getOccName ) +import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName ) import PprType ( pprConstraint ) import SpecEnv ( SpecEnv, lookupSpecEnv ) import SrcLoc ( SrcLoc ) @@ -374,10 +374,16 @@ instToId inst = instToIdBndr inst instToIdBndr :: Inst -> TcId instToIdBndr (Dict u clas ty orig loc) - = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) + = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc instToIdBndr (Method u id tys theta tau orig loc) - = mkUserLocal (getOccName id) u tau + = mkUserLocal (getOccName id) u tau loc + -- We used to call mkMethodOcc here, but that gives rise to bad + -- error messages when we print the function name or pattern + -- of an instance-decl binding. Why? Because the binding is zapped + -- to use the method name in place of the selector name. + -- The way it is now, -ddump-xx output may look confusing, but + -- you can always say -dppr-debug to get the uniques instToIdBndr (LitInst u list ty orig loc) = mkSysLocal SLIT("lit") u ty diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 9bb8089f6a..fb13e26ef5 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -11,7 +11,7 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders ) -import RdrHsSyn ( RdrName, RdrNameMonoBinds ) +import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) import CmdLineOpts ( opt_D_dump_deriv ) @@ -39,6 +39,7 @@ import Name ( isLocallyDefined, getSrcLoc, Name, Module, NamedThing(..), OccName, nameOccName ) +import RdrName ( RdrName ) import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index fe0cac9de1..158e22b4e0 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -21,7 +21,7 @@ module TcEnv( tcLookupValueByKey, tcLookupValueByKeyMaybe, explicitLookupValueByKey, explicitLookupValue, - newLocalIds, newLocalId, newSpecPragmaId, + newLocalId, newSpecPragmaId, tcGetGlobalTyVars, tcExtendGlobalTyVars, badCon, badPrimOp @@ -54,9 +54,8 @@ import TcMonad import BasicTypes ( Arity ) import IdInfo ( noIdInfo ) -import Name ( Name, OccName, nameOccName, occNameString, mkLocalName, +import Name ( Name, OccName, nameOccName, getSrcLoc, maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined, - isSysLocalName, NamedThing(..) ) import Unique ( pprUnique10, Unique, Uniquable(..) ) @@ -66,6 +65,7 @@ import Unique ( Uniquable(..) ) import Util ( zipEqual, zipWith3Equal, mapAccumL ) import Bag ( bagToList ) import Maybes ( maybeToBool ) +import SrcLoc ( SrcLoc ) import FastString ( FastString ) import Outputable \end{code} @@ -399,24 +399,15 @@ tcAddImportedIdInfo unf_env id %************************************************************************ \begin{code} -newLocalId :: OccName -> TcType -> NF_TcM s TcId -newLocalId name ty +newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId +newLocalId name ty loc = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkUserLocal name uniq ty) - -newLocalIds :: [OccName] -> [TcType] -> NF_TcM s [TcId] -newLocalIds names tys - = tcGetUniques (length names) `thenNF_Tc` \ uniqs -> - let - new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys - mk_id name uniq ty = mkUserLocal name uniq ty - in - returnNF_Tc new_ids + returnNF_Tc (mkUserLocal name uniq ty loc) newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId newSpecPragmaId name ty = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty) + returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6c32a246d3..b7ddf906b2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -1017,7 +1017,7 @@ wrongArgsCtxt too_many_or_few fun args the_app = foldl HsApp fun args -- Used in error messages appCtxt fun args - = ptext SLIT("In the application") <+> (ppr the_app) + = ptext SLIT("In the application") <+> quotes (ppr the_app) where the_app = foldl HsApp fun args -- Used in error messages diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 3208c7b92d..3b70db5a16 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -156,7 +156,7 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = -- than its declared/inferred type. Hence the need -- to create a local binding which will call the exported function -- at a particular type (and, maybe, overloading). - newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i -> + newLocalId (nameOccName nm) sig_tc_ty src_loc `thenNF_Tc` \ i -> let bind = VarMonoBind i rhs in diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 09e4992c63..4d489229de 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -31,17 +31,18 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), HsBinds(..), StmtCtxt(..), unguardedRHS, mkSimpleMatch ) -import RdrHsSyn ( RdrName(..), varUnqual, mkOpApp, - RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat - ) -import BasicTypes ( IfaceFlavour(..), RecFlag(..) ) +import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) +import RdrName ( RdrName, mkSrcUnqual ) +import BasicTypes ( RecFlag(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, DataCon, ConTag, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, - modAndOcc, OccName, Name ) + nameRdrName, varName, + OccName, Name, NamedThing(..), NameSpace + ) import PrimOp ( PrimOp(..) ) import PrelInfo -- Lots of RdrNames @@ -1239,7 +1240,8 @@ genOpApp e1 op e2 = mkOpApp e1 op e2 \end{code} \begin{code} -qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile } +qual_orig_name n = nameRdrName (getName n) +varUnqual n = mkSrcUnqual varName n a_RDR = varUnqual SLIT("a") b_RDR = varUnqual SLIT("b") diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index aa21d9881f..8005b0b7a7 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -183,8 +183,16 @@ tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src in -- Check for respectable instance type, and context - scrutiniseInstanceHead clas inst_tys `thenNF_Tc_` - mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_` + -- but only do this for non-imported instance decls. + -- Imported ones should have been checked already, and may indeed + -- contain something illegal in normal Haskell, notably + -- instance CCallable [Char] + (if isLocallyDefined dfun_name then + scrutiniseInstanceHead clas inst_tys `thenNF_Tc_` + mapNF_Tc scrutiniseInstanceConstraint theta + else + returnNF_Tc [] + ) `thenNF_Tc_` -- Make the dfun id and constant-method ids let diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 58ddd037c4..c5900a81b3 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -378,7 +378,7 @@ sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1 \begin{code} matchCtxt CaseAlt match - = hang (ptext SLIT("In a \"case\" branch:")) + = hang (ptext SLIT("In a case alternative:")) 4 (pprMatch (True,empty) {-is_case-} match) matchCtxt (FunRhs fun) match diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 507638bfad..ef3c6709f2 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -43,7 +43,7 @@ import Bag ( bagToList ) import ErrUtils ( Message ) import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) -import Name ( Name, OccName, isTvOcc, getOccName, isLocallyDefined ) +import Name ( Name, OccName, isLocallyDefined ) import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy ) import SrcLoc ( SrcLoc ) import Unique ( Unique, Uniquable(..) ) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 9242f1918c..e3749a0932 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -69,12 +69,16 @@ tcVarPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphi tcVarPat sig_fn binder_name pat_ty = case sig_fn binder_name of - Nothing -> newLocalId (getOccName binder_name) pat_ty `thenNF_Tc` \ bndr_id -> + Nothing -> -- Need to make a new, monomorphic, Id + -- The binder_name is already being used for the polymorphic Id + newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id -> returnTc bndr_id - Just bndr_id -> tcAddSrcLoc (getSrcLoc binder_name) $ - unifyTauTy (idType bndr_id) pat_ty `thenTc_` + Just bndr_id -> tcAddSrcLoc loc $ + unifyTauTy (idType bndr_id) pat_ty `thenTc_` returnTc bndr_id + where + loc = getSrcLoc binder_name \end{code} diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index a6bf468fd3..6fd0ba76a1 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -24,7 +24,7 @@ import Type ( Type(..), tyVarsOfType, funTyCon, ) import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, tyConArity ) -import Name ( isSysLocalName ) +import Name ( isSystemName ) import Var ( TyVar, tyVarKind, varName ) import VarEnv import VarSet ( varSetElems ) @@ -141,7 +141,7 @@ uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) -- Type constructors must match uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) = checkTcM (cons_match && length tys1 == length tys2) - (failWithTcM (unifyMisMatch ps_ty1 ps_ty2)) `thenTc_` + (unifyMisMatch ps_ty1 ps_ty2) `thenTc_` unifyTauTyLists tys1 tys2 where -- The AnyBox wild card matches anything @@ -156,21 +156,21 @@ uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2 = case splitAppTy_maybe ty2 of Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 - Nothing -> failWithTcM (unifyMisMatch ps_ty1 ps_ty2) + Nothing -> unifyMisMatch ps_ty1 ps_ty2 -- Now the same, but the other way round -- Don't swap the types, because the error messages get worse uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) = case splitAppTy_maybe ty1 of Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 - Nothing -> failWithTcM (unifyMisMatch ps_ty1 ps_ty2) + Nothing -> unifyMisMatch ps_ty1 ps_ty2 -- Not expecting for-alls in unification -- ... but the error message from the unifyMisMatch more informative -- than a panic message! -- Anything else fails -uTys ps_ty1 ty1 ps_ty2 ty2 = failWithTcM (unifyMisMatch ps_ty1 ps_ty2) +uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 \end{code} Notes on synonyms @@ -272,8 +272,8 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) Nothing -> checkKinds swapped tv1 ty2 `thenTc_` -- Try to update sys-y type variables in preference to sig-y ones - -- (the latter respond False to isSysLocalName) - if isSysLocalName (varName tv2) then + -- (the latter respond False to isSystemName) + if isSystemName (varName tv2) then tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () else @@ -472,11 +472,16 @@ unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 infer pp2 = ppr ty2' unifyMisMatch ty1 ty2 - = (env2, hang (ptext SLIT("Couldn't match")) - 4 (sep [quotes (ppr tidy_ty1), ptext SLIT("against"), quotes (ppr tidy_ty2)])) - where - (env1, tidy_ty1) = tidyOpenType emptyTidyEnv ty1 - (env2, tidy_ty2) = tidyOpenType env1 ty2 + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> + let + (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] + msg = hang (ptext SLIT("Couldn't match")) + 4 (sep [quotes (ppr tidy_ty1), + ptext SLIT("against"), + quotes (ppr tidy_ty2)]) + in + failWithTcM (env, msg) unifyOccurCheck tyvar ty = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:")) diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 40e7266e9b..7dfd9536e4 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -163,9 +163,9 @@ 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, pp_ctxt, pp_body ] + sep [ ptext SLIT("__forall") <+> brackets pp_tyvars, pp_ctxt, pp_body ] else - sep [ ptext SLIT("forall"), pp_tyvars <> ptext SLIT("."), pp_maybe_ctxt, pp_body ] + sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), pp_maybe_ctxt, pp_body ] where (tyvars, rho_ty) = splitForAllTys ty (theta, body_ty) = splitRhoTy rho_ty diff --git a/ghc/compiler/types/TyCon.hi-boot b/ghc/compiler/types/TyCon.hi-boot index 930f95809a..3d7d4b3785 100644 --- a/ghc/compiler/types/TyCon.hi-boot +++ b/ghc/compiler/types/TyCon.hi-boot @@ -1,9 +1,11 @@ _interface_ TyCon 1 _exports_ -TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon; +TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon setTyConName ; _declarations_ 1 data TyCon; 1 isTupleTyCon _:_ TyCon -> PrelBase.Bool ;; 1 isUnboxedTupleTyCon _:_ TyCon -> PrelBase.Bool ;; 1 isFunTyCon _:_ TyCon -> PrelBase.Bool ;; +1 setTyConName _:_ TyCon -> Name.Name -> TyCon ;; + diff --git a/ghc/compiler/types/TyCon.hi-boot-5 b/ghc/compiler/types/TyCon.hi-boot-5 index 0b9fe835be..15ab3ead3f 100644 --- a/ghc/compiler/types/TyCon.hi-boot-5 +++ b/ghc/compiler/types/TyCon.hi-boot-5 @@ -1,6 +1,7 @@ __interface TyCon 1 0 where -__export TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon; +__export TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon setTyConName ; 1 data TyCon ; 1 isTupleTyCon :: TyCon -> PrelBase.Bool ; 1 isUnboxedTupleTyCon :: TyCon -> PrelBase.Bool ; 1 isFunTyCon :: TyCon -> PrelBase.Bool ; +1 setTyConName :: TyCon -> Name.Name -> TyCon ; diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index fb969bc004..c3c95b8558 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -19,6 +19,8 @@ module TyCon( mkKindCon, mkSuperKindCon, + setTyConName, + tyConKind, tyConUnique, tyConTyVars, @@ -224,6 +226,8 @@ mkSynTyCon name kind arity tyvars rhs tyConTyVars = tyvars, synTyConDefn = rhs } + +setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 3078d8d529..c0e20d2047 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -64,13 +64,13 @@ import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages -- friends: import Var ( Id, TyVar, IdOrTyVar, - tyVarKind, isId, idType, setVarOcc + tyVarKind, tyVarName, isId, idType, setTyVarName ) import VarEnv import VarSet import Name ( NamedThing(..), Provenance(..), ExportFlag(..), - mkWiredInTyConName, mkGlobalName, tcOcc, + mkWiredInTyConName, mkGlobalName, mkLocalName, mkKindOccFS, tcName, tidyOccName, TidyOccEnv ) import NameSet @@ -86,7 +86,7 @@ import TyCon ( TyCon, KindCon, -- others import BasicTypes ( Unused ) -import SrcLoc ( mkBuiltinSrcLoc ) +import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc ) import PrelMods ( pREL_GHC ) import Maybes ( maybeToBool ) import PrimRep ( PrimRep(..), isFollowableRep ) @@ -219,7 +219,7 @@ sk = KX -- A kind | sk -> sk -- In ptic (BX -> KX) \begin{code} -mk_kind_name key str = mkGlobalName key pREL_GHC (tcOcc str) +mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str) (LocalDef mkBuiltinSrcLoc NotExported) -- mk_kind_name is a bit of a hack -- The LocalDef means that we print the name without @@ -300,7 +300,7 @@ hasMoreBoxityInfo k1 k2 We define a few wired-in type constructors here to avoid module knots \begin{code} -funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") funTyCon +funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind) \end{code} @@ -842,12 +842,17 @@ tidyTyVar env@(tidy_env, subst) tyvar Nothing -> -- Make a new nice name for it - case tidyOccName tidy_env (getOccName tyvar) of + case tidyOccName tidy_env (getOccName name) of (tidy', occ') -> -- New occname reqd ((tidy', subst'), tyvar') where subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setVarOcc tyvar occ' + tyvar' = setTyVarName tyvar name' + name' = mkLocalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. + where + name = tyVarName tyvar tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 582a0b63bf..dfefd854b3 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -41,8 +41,8 @@ module Outputable ( -- error handling - pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, - trace, panic, panic#, assertPanic, warnPprTrace + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, + trace, panic, panic#, assertPanic ) where #include "HsVersions.h" @@ -207,9 +207,17 @@ rational n sty = Pretty.rational n parens d sty = Pretty.parens (d sty) braces d sty = Pretty.braces (d sty) brackets d sty = Pretty.brackets (d sty) -quotes d sty = Pretty.quotes (d sty) doubleQuotes d sty = Pretty.doubleQuotes (d sty) +-- quotes encloses something in single quotes... +-- but it omits them if the thing ends in a single quote +-- so that we don't get `foo''. Instead we just have foo'. +quotes d sty = case show pp_d of + ('\'' : _) -> pp_d + other -> Pretty.quotes pp_d + where + pp_d = d sty + semi sty = Pretty.semi comma sty = Pretty.comma colon sty = Pretty.colon diff --git a/ghc/includes/Prelude.h b/ghc/includes/Prelude.h index deab0b808f..dedfdbe605 100644 --- a/ghc/includes/Prelude.h +++ b/ghc/includes/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.3 1999/01/26 11:12:56 simonm Exp $ + * $Id: Prelude.h,v 1.4 1999/01/27 14:51:14 simonpj Exp $ * * Prelude identifiers that we sometimes need to refer to in the RTS. * @@ -16,20 +16,20 @@ extern const StgClosure PrelBase_False_static_closure; extern const StgClosure PrelMain_mainIO_closure; extern const StgClosure PrelPack_unpackCString_closure; -extern const StgInfoTable PrelBase_CZh_static_info; -extern const StgInfoTable PrelBase_IZh_static_info; -extern const StgInfoTable PrelBase_FZh_static_info; -extern const StgInfoTable PrelBase_DZh_static_info; -extern const StgInfoTable PrelAddr_AZh_static_info; -extern const StgInfoTable PrelAddr_WZh_static_info; -extern const StgInfoTable PrelBase_CZh_con_info; -extern const StgInfoTable PrelBase_IZh_con_info; -extern const StgInfoTable PrelBase_FZh_con_info; -extern const StgInfoTable PrelBase_DZh_con_info; -extern const StgInfoTable PrelAddr_AZh_con_info; -extern const StgInfoTable PrelAddr_WZh_con_info; -extern const StgInfoTable PrelAddr_I64Zh_con_info; -extern const StgInfoTable PrelAddr_W64Zh_con_info; +extern const StgInfoTable PrelBase_Czh_static_info; +extern const StgInfoTable PrelBase_Izh_static_info; +extern const StgInfoTable PrelBase_Fzh_static_info; +extern const StgInfoTable PrelBase_Dzh_static_info; +extern const StgInfoTable PrelAddr_Azh_static_info; +extern const StgInfoTable PrelAddr_Wzh_static_info; +extern const StgInfoTable PrelBase_Czh_con_info; +extern const StgInfoTable PrelBase_Izh_con_info; +extern const StgInfoTable PrelBase_Fzh_con_info; +extern const StgInfoTable PrelBase_Dzh_con_info; +extern const StgInfoTable PrelAddr_Azh_con_info; +extern const StgInfoTable PrelAddr_Wzh_con_info; +extern const StgInfoTable PrelAddr_I64zh_con_info; +extern const StgInfoTable PrelAddr_W64zh_con_info; extern const StgInfoTable PrelStable_StablePtr_static_info; extern const StgInfoTable PrelStable_StablePtr_con_info; @@ -37,51 +37,52 @@ extern const StgInfoTable PrelStable_StablePtr_con_info; * module these names are defined in. */ -#define Nil_closure PrelBase_Z91Z93_static_closure -#define Unit_closure PrelBase_Z40Z41_static_closure +#define Nil_closure PrelBase_ZMZN_static_closure +#define Unit_closure PrelBase_Z0T_static_closure #define True_closure PrelBase_True_static_closure #define False_closure PrelBase_False_static_closure -#define CZh_static_info PrelBase_CZh_static_info -#define IZh_static_info PrelBase_IZh_static_info -#define FZh_static_info PrelBase_FZh_static_info -#define DZh_static_info PrelBase_DZh_static_info -#define AZh_static_info PrelAddr_AZh_static_info -#define WZh_static_info PrelAddr_WZh_static_info -#define CZh_con_info PrelBase_CZh_con_info -#define IZh_con_info PrelBase_IZh_con_info -#define FZh_con_info PrelBase_FZh_con_info -#define DZh_con_info PrelBase_DZh_con_info -#define AZh_con_info PrelAddr_AZh_con_info -#define WZh_con_info PrelAddr_WZh_con_info -#define W64Zh_con_info PrelAddr_W64Zh_con_info -#define I64Zh_con_info PrelAddr_I64Zh_con_info +#define Czh_static_info PrelBase_Czh_static_info +#define Izh_static_info PrelBase_Izh_static_info +#define Fzh_static_info PrelBase_Fzh_static_info +#define Dzh_static_info PrelBase_Dzh_static_info +#define Azh_static_info PrelAddr_Azh_static_info +#define Wzh_static_info PrelAddr_Wzh_static_info +#define Czh_con_info PrelBase_Czh_con_info +#define Izh_con_info PrelBase_Izh_con_info +#define Fzh_con_info PrelBase_Fzh_con_info +#define Dzh_con_info PrelBase_Dzh_con_info +#define Azh_con_info PrelAddr_Azh_con_info +#define Wzh_con_info PrelAddr_Wzh_con_info +#define W64zh_con_info PrelAddr_W64zh_con_info +#define I64zh_con_info PrelAddr_I64zh_con_info #define StablePtr_static_info PrelStable_StablePtr_static_info #define StablePtr_con_info PrelStable_StablePtr_con_info + #define mainIO_closure PrelMain_mainIO_closure #define unpackCString_closure PrelPack_unpackCString_closure #else /* INTERPRETER, I guess */ -extern const StgInfoTable CZh_con_info; -extern const StgInfoTable IZh_con_info; -extern const StgInfoTable I64Zh_con_info; -extern const StgInfoTable FZh_con_info; -extern const StgInfoTable DZh_con_info; -extern const StgInfoTable AZh_con_info; -extern const StgInfoTable WZh_con_info; +extern const StgInfoTable Czh_con_info; +extern const StgInfoTable Izh_con_info; +extern const StgInfoTable I64zh_con_info; +extern const StgInfoTable Fzh_con_info; +extern const StgInfoTable Dzh_con_info; +extern const StgInfoTable Azh_con_info; +extern const StgInfoTable Wzh_con_info; extern const StgInfoTable StablePtr_con_info; -extern const StgInfoTable CZh_static_info; -extern const StgInfoTable IZh_static_info; -extern const StgInfoTable I64Zh_static_info; -extern const StgInfoTable FZh_static_info; -extern const StgInfoTable DZh_static_info; -extern const StgInfoTable AZh_static_info; -extern const StgInfoTable WZh_static_info; +extern const StgInfoTable Czh_static_info; +extern const StgInfoTable Izh_static_info; +extern const StgInfoTable I64zh_static_info; +extern const StgInfoTable Fzh_static_info; +extern const StgInfoTable Dzh_static_info; +extern const StgInfoTable Azh_static_info; +extern const StgInfoTable Wzh_static_info; extern const StgInfoTable StablePtr_static_info; -#define W64Zh_con_info I64Zh_con_info -#define W64Zh_static_info I64Zh_con_info +#define W64zh_con_info I64zh_con_info +#define W64zh_static_info I64zh_con_info #endif diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index 67dd76e13c..932500bbe1 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.10 1999/01/26 11:12:56 simonm Exp $ + * $Id: PrimOps.h,v 1.11 1999/01/27 14:51:15 simonpj Exp $ * * Macros for primitive operations in STG-ish C code. * @@ -12,49 +12,49 @@ Comparison PrimOps. -------------------------------------------------------------------------- */ -#define gtCharZh(r,a,b) r=(I_)((a)> (b)) -#define geCharZh(r,a,b) r=(I_)((a)>=(b)) -#define eqCharZh(r,a,b) r=(I_)((a)==(b)) -#define neCharZh(r,a,b) r=(I_)((a)!=(b)) -#define ltCharZh(r,a,b) r=(I_)((a)< (b)) -#define leCharZh(r,a,b) r=(I_)((a)<=(b)) +#define gtCharzh(r,a,b) r=(I_)((a)> (b)) +#define geCharzh(r,a,b) r=(I_)((a)>=(b)) +#define eqCharzh(r,a,b) r=(I_)((a)==(b)) +#define neCharzh(r,a,b) r=(I_)((a)!=(b)) +#define ltCharzh(r,a,b) r=(I_)((a)< (b)) +#define leCharzh(r,a,b) r=(I_)((a)<=(b)) /* Int comparisons: >#, >=# etc */ -#define ZgZh(r,a,b) r=(I_)((I_)(a) >(I_)(b)) -#define ZgZeZh(r,a,b) r=(I_)((I_)(a)>=(I_)(b)) -#define ZeZeZh(r,a,b) r=(I_)((I_)(a)==(I_)(b)) -#define ZdZeZh(r,a,b) r=(I_)((I_)(a)!=(I_)(b)) -#define ZlZh(r,a,b) r=(I_)((I_)(a) <(I_)(b)) -#define ZlZeZh(r,a,b) r=(I_)((I_)(a)<=(I_)(b)) - -#define gtWordZh(r,a,b) r=(I_)((W_)(a) >(W_)(b)) -#define geWordZh(r,a,b) r=(I_)((W_)(a)>=(W_)(b)) -#define eqWordZh(r,a,b) r=(I_)((W_)(a)==(W_)(b)) -#define neWordZh(r,a,b) r=(I_)((W_)(a)!=(W_)(b)) -#define ltWordZh(r,a,b) r=(I_)((W_)(a) <(W_)(b)) -#define leWordZh(r,a,b) r=(I_)((W_)(a)<=(W_)(b)) - -#define gtAddrZh(r,a,b) r=(I_)((a) >(b)) -#define geAddrZh(r,a,b) r=(I_)((a)>=(b)) -#define eqAddrZh(r,a,b) r=(I_)((a)==(b)) -#define neAddrZh(r,a,b) r=(I_)((a)!=(b)) -#define ltAddrZh(r,a,b) r=(I_)((a) <(b)) -#define leAddrZh(r,a,b) r=(I_)((a)<=(b)) - -#define gtFloatZh(r,a,b) r=(I_)((a)> (b)) -#define geFloatZh(r,a,b) r=(I_)((a)>=(b)) -#define eqFloatZh(r,a,b) r=(I_)((a)==(b)) -#define neFloatZh(r,a,b) r=(I_)((a)!=(b)) -#define ltFloatZh(r,a,b) r=(I_)((a)< (b)) -#define leFloatZh(r,a,b) r=(I_)((a)<=(b)) +#define zgzh(r,a,b) r=(I_)((I_)(a) >(I_)(b)) +#define zgzezh(r,a,b) r=(I_)((I_)(a)>=(I_)(b)) +#define zezezh(r,a,b) r=(I_)((I_)(a)==(I_)(b)) +#define zszezh(r,a,b) r=(I_)((I_)(a)!=(I_)(b)) +#define zlzh(r,a,b) r=(I_)((I_)(a) <(I_)(b)) +#define zlzezh(r,a,b) r=(I_)((I_)(a)<=(I_)(b)) + +#define gtWordzh(r,a,b) r=(I_)((W_)(a) >(W_)(b)) +#define geWordzh(r,a,b) r=(I_)((W_)(a)>=(W_)(b)) +#define eqWordzh(r,a,b) r=(I_)((W_)(a)==(W_)(b)) +#define neWordzh(r,a,b) r=(I_)((W_)(a)!=(W_)(b)) +#define ltWordzh(r,a,b) r=(I_)((W_)(a) <(W_)(b)) +#define leWordzh(r,a,b) r=(I_)((W_)(a)<=(W_)(b)) + +#define gtAddrzh(r,a,b) r=(I_)((a) >(b)) +#define geAddrzh(r,a,b) r=(I_)((a)>=(b)) +#define eqAddrzh(r,a,b) r=(I_)((a)==(b)) +#define neAddrzh(r,a,b) r=(I_)((a)!=(b)) +#define ltAddrzh(r,a,b) r=(I_)((a) <(b)) +#define leAddrzh(r,a,b) r=(I_)((a)<=(b)) + +#define gtFloatzh(r,a,b) r=(I_)((a)> (b)) +#define geFloatzh(r,a,b) r=(I_)((a)>=(b)) +#define eqFloatzh(r,a,b) r=(I_)((a)==(b)) +#define neFloatzh(r,a,b) r=(I_)((a)!=(b)) +#define ltFloatzh(r,a,b) r=(I_)((a)< (b)) +#define leFloatzh(r,a,b) r=(I_)((a)<=(b)) /* Double comparisons: >##, >=#@ etc */ -#define ZgZhZh(r,a,b) r=(I_)((a) >(b)) -#define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b)) -#define ZeZeZhZh(r,a,b) r=(I_)((a)==(b)) -#define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b)) -#define ZlZhZh(r,a,b) r=(I_)((a) <(b)) -#define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b)) +#define zgzhzh(r,a,b) r=(I_)((a) >(b)) +#define zgzezhzh(r,a,b) r=(I_)((a)>=(b)) +#define zezezhzh(r,a,b) r=(I_)((a)==(b)) +#define zszezhzh(r,a,b) r=(I_)((a)!=(b)) +#define zlzhzh(r,a,b) r=(I_)((a) <(b)) +#define zlzezhzh(r,a,b) r=(I_)((a)<=(b)) /* used by returning comparison primops, defined in Prims.hc. */ extern const StgClosure *PrelBase_Bool_closure_tbl[]; @@ -63,8 +63,8 @@ extern const StgClosure *PrelBase_Bool_closure_tbl[]; Char# PrimOps. -------------------------------------------------------------------------- */ -#define ordZh(r,a) r=(I_)((W_) (a)) -#define chrZh(r,a) r=(StgChar)((W_)(a)) +#define ordzh(r,a) r=(I_)((W_) (a)) +#define chrzh(r,a) r=(StgChar)((W_)(a)) /* ----------------------------------------------------------------------------- Int# PrimOps. @@ -72,13 +72,13 @@ extern const StgClosure *PrelBase_Bool_closure_tbl[]; I_ stg_div (I_ a, I_ b); -#define ZpZh(r,a,b) r=(a)+(b) -#define ZmZh(r,a,b) r=(a)-(b) -#define ZtZh(r,a,b) r=(a)*(b) -#define quotIntZh(r,a,b) r=(a)/(b) -#define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b)) -#define remIntZh(r,a,b) r=(a)%(b) -#define negateIntZh(r,a) r=-(a) +#define zpzh(r,a,b) r=(a)+(b) +#define zmzh(r,a,b) r=(a)-(b) +#define ztzh(r,a,b) r=(a)*(b) +#define quotIntzh(r,a,b) r=(a)/(b) +#define zszh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b)) +#define remIntzh(r,a,b) r=(a)%(b) +#define negateIntzh(r,a) r=-(a) /* The following operations are the standard add,subtract and multiply * except that they return a carry if the operation overflows. @@ -102,7 +102,7 @@ typedef union { StgInt32 i[2]; } long_long_u ; -#define addWithCarryZh(r,c,a,b) \ +#define addWithCarryzh(r,c,a,b) \ { long_long_u z; \ z.l = a + b; \ r = z.i[R]; \ @@ -110,15 +110,14 @@ typedef union { } - -#define subWithCarryZh(r,c,a,b) \ +#define subWithCarryzh(r,c,a,b) \ { long_long_u z; \ z.l = a + b; \ r = z.i[R]; \ c = z.i[C]; \ } -#define mulWithCarryZh(r,c,a,b) \ +#define mulWithCarryzh(r,c,a,b) \ { long_long_u z; \ z.l = a * b; \ r = z.i[R]; \ @@ -129,115 +128,115 @@ typedef union { Word PrimOps. -------------------------------------------------------------------------- */ -#define quotWordZh(r,a,b) r=((W_)a)/((W_)b) -#define remWordZh(r,a,b) r=((W_)a)%((W_)b) +#define quotWordzh(r,a,b) r=((W_)a)/((W_)b) +#define remWordzh(r,a,b) r=((W_)a)%((W_)b) -#define andZh(r,a,b) r=(a)&(b) -#define orZh(r,a,b) r=(a)|(b) -#define xorZh(r,a,b) r=(a)^(b) -#define notZh(r,a) r=~(a) +#define andzh(r,a,b) r=(a)&(b) +#define orzh(r,a,b) r=(a)|(b) +#define xorzh(r,a,b) r=(a)^(b) +#define notzh(r,a) r=~(a) -#define shiftLZh(r,a,b) r=(a)<<(b) -#define shiftRLZh(r,a,b) r=(a)>>(b) -#define iShiftLZh(r,a,b) r=(a)<<(b) +#define shiftLzh(r,a,b) r=(a)<<(b) +#define shiftRLzh(r,a,b) r=(a)>>(b) +#define iShiftLzh(r,a,b) r=(a)<<(b) /* Right shifting of signed quantities is not portable in C, so the behaviour you'll get from using these primops depends on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98 */ -#define iShiftRAZh(r,a,b) r=(a)>>(b) -#define iShiftRLZh(r,a,b) r=(a)>>(b) +#define iShiftRAzh(r,a,b) r=(a)>>(b) +#define iShiftRLzh(r,a,b) r=(a)>>(b) -#define int2WordZh(r,a) r=(W_)(a) -#define word2IntZh(r,a) r=(I_)(a) +#define int2Wordzh(r,a) r=(W_)(a) +#define word2Intzh(r,a) r=(I_)(a) /* ----------------------------------------------------------------------------- Addr PrimOps. -------------------------------------------------------------------------- */ -#define int2AddrZh(r,a) r=(A_)(a) -#define addr2IntZh(r,a) r=(I_)(a) +#define int2Addrzh(r,a) r=(A_)(a) +#define addr2Intzh(r,a) r=(I_)(a) -#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i] -#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i] -#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i] -#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i)) -#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i)) -#define indexStablePtrOffAddrZh(r,a,i) r= ((StgStablePtr *)(a))[i] +#define indexCharOffAddrzh(r,a,i) r= ((C_ *)(a))[i] +#define indexIntOffAddrzh(r,a,i) r= ((I_ *)(a))[i] +#define indexAddrOffAddrzh(r,a,i) r= ((PP_)(a))[i] +#define indexFloatOffAddrzh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i)) +#define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i)) +#define indexStablePtrOffAddrzh(r,a,i) r= ((StgStablePtr *)(a))[i] #ifdef SUPPORT_LONG_LONGS -#define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i] -#define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i] +#define indexInt64OffAddrzh(r,a,i) r= ((LI_ *)(a))[i] +#define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i] #endif -#define writeCharOffAddrZh(a,i,v) ((C_ *)(a))[i] = (v) -#define writeIntOffAddrZh(a,i,v) ((I_ *)(a))[i] = (v) -#define writeWordOffAddrZh(a,i,v) ((W_ *)(a))[i] = (v) -#define writeAddrOffAddrZh(a,i,v) ((PP_)(a))[i] = (v) -#define writeForeignObjOffAddrZh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v) -#define writeFloatOffAddrZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v) -#define writeDoubleOffAddrZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v) -#define writeStablePtrOffAddrZh(a,i,v) ((StgStablePtr *)(a))[i] = (v) +#define writeCharOffAddrzh(a,i,v) ((C_ *)(a))[i] = (v) +#define writeIntOffAddrzh(a,i,v) ((I_ *)(a))[i] = (v) +#define writeWordOffAddrzh(a,i,v) ((W_ *)(a))[i] = (v) +#define writeAddrOffAddrzh(a,i,v) ((PP_)(a))[i] = (v) +#define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v) +#define writeFloatOffAddrzh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v) +#define writeDoubleOffAddrzh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v) +#define writeStablePtrOffAddrzh(a,i,v) ((StgStablePtr *)(a))[i] = (v) #ifdef SUPPORT_LONG_LONGS -#define writeInt64OffAddrZh(a,i,v) ((LI_ *)(a))[i] = (v) -#define writeWord64OffAddrZh(a,i,v) ((LW_ *)(a))[i] = (v) +#define writeInt64OffAddrzh(a,i,v) ((LI_ *)(a))[i] = (v) +#define writeWord64OffAddrzh(a,i,v) ((LW_ *)(a))[i] = (v) #endif /* ----------------------------------------------------------------------------- Float PrimOps. -------------------------------------------------------------------------- */ -#define plusFloatZh(r,a,b) r=(a)+(b) -#define minusFloatZh(r,a,b) r=(a)-(b) -#define timesFloatZh(r,a,b) r=(a)*(b) -#define divideFloatZh(r,a,b) r=(a)/(b) -#define negateFloatZh(r,a) r=-(a) +#define plusFloatzh(r,a,b) r=(a)+(b) +#define minusFloatzh(r,a,b) r=(a)-(b) +#define timesFloatzh(r,a,b) r=(a)*(b) +#define divideFloatzh(r,a,b) r=(a)/(b) +#define negateFloatzh(r,a) r=-(a) -#define int2FloatZh(r,a) r=(StgFloat)(a) -#define float2IntZh(r,a) r=(I_)(a) +#define int2Floatzh(r,a) r=(StgFloat)(a) +#define float2Intzh(r,a) r=(I_)(a) -#define expFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a) -#define logFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a) -#define sqrtFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a) -#define sinFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a) -#define cosFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a) -#define tanFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a) -#define asinFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a) -#define acosFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a) -#define atanFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a) -#define sinhFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a) -#define coshFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a) -#define tanhFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a) -#define powerFloatZh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b) +#define expFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a) +#define logFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a) +#define sqrtFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a) +#define sinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a) +#define cosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a) +#define tanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a) +#define asinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a) +#define acosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a) +#define atanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a) +#define sinhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a) +#define coshFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a) +#define tanhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a) +#define powerFloatzh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b) /* ----------------------------------------------------------------------------- Double PrimOps. -------------------------------------------------------------------------- */ -#define ZpZhZh(r,a,b) r=(a)+(b) -#define ZmZhZh(r,a,b) r=(a)-(b) -#define ZtZhZh(r,a,b) r=(a)*(b) -#define ZdZhZh(r,a,b) r=(a)/(b) -#define negateDoubleZh(r,a) r=-(a) +#define zpzhzh(r,a,b) r=(a)+(b) +#define zmzhzh(r,a,b) r=(a)-(b) +#define ztzhzh(r,a,b) r=(a)*(b) +#define zszhzh(r,a,b) r=(a)/(b) +#define negateDoublezh(r,a) r=-(a) -#define int2DoubleZh(r,a) r=(StgDouble)(a) -#define double2IntZh(r,a) r=(I_)(a) +#define int2Doublezh(r,a) r=(StgDouble)(a) +#define double2Intzh(r,a) r=(I_)(a) -#define float2DoubleZh(r,a) r=(StgDouble)(a) -#define double2FloatZh(r,a) r=(StgFloat)(a) +#define float2Doublezh(r,a) r=(StgDouble)(a) +#define double2Floatzh(r,a) r=(StgFloat)(a) -#define expDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a) -#define logDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a) -#define sqrtDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a) -#define sinDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a) -#define cosDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a) -#define tanDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a) -#define asinDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a) -#define acosDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a) -#define atanDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a) -#define sinhDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a) -#define coshDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a) -#define tanhDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a) +#define expDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a) +#define logDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a) +#define sqrtDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a) +#define sinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a) +#define cosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a) +#define tanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a) +#define asinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a) +#define acosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a) +#define atanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a) +#define sinhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a) +#define coshDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a) +#define tanhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a) /* Power: **## */ -#define ZtZtZhZh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b) +#define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b) /* ----------------------------------------------------------------------------- Integer PrimOps. @@ -247,7 +246,7 @@ typedef union { * to allocate any memory. */ -#define integer2IntZh(r, aa,sa,da) \ +#define integer2Intzh(r, aa,sa,da) \ { MP_INT arg; \ \ arg._mp_alloc = (aa); \ @@ -257,7 +256,7 @@ typedef union { (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \ } -#define integer2WordZh(r, aa,sa,da) \ +#define integer2Wordzh(r, aa,sa,da) \ { MP_INT arg; \ \ arg._mp_alloc = (aa); \ @@ -267,7 +266,7 @@ typedef union { (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \ } -#define cmpIntegerZh(r, a1,s1,d1, a2,s2,d2) \ +#define cmpIntegerzh(r, a1,s1,d1, a2,s2,d2) \ { MP_INT arg1; \ MP_INT arg2; \ \ @@ -286,7 +285,7 @@ typedef union { * derive a better version: */ -#define negateIntegerZh(ra, rs, rd, a, s, d) \ +#define negateIntegerzh(ra, rs, rd, a, s, d) \ { \ (ra) = (a); \ (rs) = -(s); \ @@ -296,24 +295,24 @@ typedef union { /* The rest are all out-of-line: -------- */ /* Integer arithmetic */ -EF_(plusIntegerZh_fast); -EF_(minusIntegerZh_fast); -EF_(timesIntegerZh_fast); -EF_(gcdIntegerZh_fast); -EF_(quotRemIntegerZh_fast); -EF_(divModIntegerZh_fast); +EF_(plusIntegerzh_fast); +EF_(minusIntegerzh_fast); +EF_(timesIntegerzh_fast); +EF_(gcdIntegerzh_fast); +EF_(quotRemIntegerzh_fast); +EF_(divModIntegerzh_fast); /* Conversions */ -EF_(int2IntegerZh_fast); -EF_(word2IntegerZh_fast); -EF_(addr2IntegerZh_fast); +EF_(int2Integerzh_fast); +EF_(word2Integerzh_fast); +EF_(addr2Integerzh_fast); /* Floating-point encodings/decodings */ -EF_(encodeFloatZh_fast); -EF_(decodeFloatZh_fast); +EF_(encodeFloatzh_fast); +EF_(decodeFloatzh_fast); -EF_(encodeDoubleZh_fast); -EF_(decodeDoubleZh_fast); +EF_(encodeDoublezh_fast); +EF_(decodeDoublezh_fast); /* ----------------------------------------------------------------------------- Word64 PrimOps. @@ -321,7 +320,7 @@ EF_(decodeDoubleZh_fast); #ifdef SUPPORT_LONG_LONGS -#define integerToWord64Zh(r, aa,sa,da) \ +#define integerToWord64zh(r, aa,sa,da) \ { unsigned long int* d; \ StgNat64 res; \ \ @@ -336,7 +335,7 @@ EF_(decodeDoubleZh_fast); (r) = res; \ } -#define integerToInt64Zh(r, aa,sa,da) \ +#define integerToInt64zh(r, aa,sa,da) \ { unsigned long int* d; \ StgInt64 res; \ \ @@ -355,8 +354,8 @@ EF_(decodeDoubleZh_fast); } /* Conversions */ -EF_(int64ToIntegerZh_fast); -EF_(word64ToIntegerZh_fast); +EF_(int64ToIntegerzh_fast); +EF_(word64ToIntegerzh_fast); /* The rest are (way!) out of line, implemented via C entry points. */ @@ -428,80 +427,80 @@ LI_ stg_word64ToInt64 (StgNat64); #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a) #endif -extern I_ genSymZh(void); -extern I_ resetGenSymZh(void); +extern I_ genSymzh(void); +extern I_ resetGenSymzh(void); /*--- everything except new*Array is done inline: */ -#define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b)) -#define sameMutableByteArrayZh(r,a,b) r=(I_)((a)==(b)) +#define sameMutableArrayzh(r,a,b) r=(I_)((a)==(b)) +#define sameMutableByteArrayzh(r,a,b) r=(I_)((a)==(b)) -#define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] +#define readArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] -#define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i) +#define readCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i) #ifdef SUPPORT_LONG_LONGS -#define readInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i) -#define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i) +#define readInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i) +#define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i) #endif /* result ("r") arg ignored in write macros! */ -#define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v) +#define writeArrayzh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v) -#define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v) -#define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v) -#define writeWordArrayZh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v) -#define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v) -#define writeFloatArrayZh(a,i,v) \ +#define writeCharArrayzh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeIntArrayzh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeWordArrayzh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeAddrArrayzh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeFloatArrayzh(a,i,v) \ ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v) -#define writeDoubleArrayZh(a,i,v) \ +#define writeDoubleArrayzh(a,i,v) \ ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v) -#define writeStablePtrArrayZh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeStablePtrArrayzh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v) #ifdef SUPPORT_LONG_LONGS -#define writeInt64ArrayZh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v) -#define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeInt64Arrayzh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v) +#define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v) #endif -#define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] +#define indexArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] -#define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i) +#define indexCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i) #ifdef SUPPORT_LONG_LONGS -#define indexInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i) -#define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i) +#define indexInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i) +#define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i) #endif -#define indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWordOffForeignObjZh(r,fo,i) indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexAddrOffForeignObjZh(r,fo,i) indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexFloatOffForeignObjZh(r,fo,i) indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexStablePtrOffForeignObjZh(r,fo,i) indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexCharOffForeignObjzh(r,fo,i) indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexIntOffForeignObjzh(r,fo,i) indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexWordOffForeignObjzh(r,fo,i) indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexAddrOffForeignObjzh(r,fo,i) indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexFloatOffForeignObjzh(r,fo,i) indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexStablePtrOffForeignObjzh(r,fo,i) indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) #ifdef SUPPORT_LONG_LONGS -#define indexInt64OffForeignObjZh(r,fo,i) indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) -#define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexInt64OffForeignObjzh(r,fo,i) indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) +#define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) #endif -#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i] -#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i] -#define indexWordOffAddrZh(r,a,i) r= ((W_ *)(a))[i] -#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i] -#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i)) -#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i)) +#define indexCharOffAddrzh(r,a,i) r= ((C_ *)(a))[i] +#define indexIntOffAddrzh(r,a,i) r= ((I_ *)(a))[i] +#define indexWordOffAddrzh(r,a,i) r= ((W_ *)(a))[i] +#define indexAddrOffAddrzh(r,a,i) r= ((PP_)(a))[i] +#define indexFloatOffAddrzh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i)) +#define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i)) #ifdef SUPPORT_LONG_LONGS -#define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i] -#define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i] +#define indexInt64OffAddrzh(r,a,i) r= ((LI_ *)(a))[i] +#define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i] #endif /* Freezing arrays-of-ptrs requires changing an info table, for the @@ -509,29 +508,29 @@ extern I_ resetGenSymZh(void); objects, even if they are in old space. When they become immutable, they can be removed from this scavenge list. */ -#define unsafeFreezeArrayZh(r,a) \ +#define unsafeFreezzeArrayzh(r,a) \ { \ SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info); \ r = a; \ } -#define unsafeFreezeByteArrayZh(r,a) r=(a) +#define unsafeFreezzeByteArrayzh(r,a) r=(a) -#define sizeofByteArrayZh(r,a) \ +#define sizzeofByteArrayzh(r,a) \ r = (((StgArrWords *)(a))->words * sizeof(W_)) -#define sizeofMutableByteArrayZh(r,a) \ +#define sizzeofMutableByteArrayzh(r,a) \ r = (((StgArrWords *)(a))->words * sizeof(W_)) /* and the out-of-line ones... */ -EF_(newCharArrayZh_fast); -EF_(newIntArrayZh_fast); -EF_(newWordArrayZh_fast); -EF_(newAddrArrayZh_fast); -EF_(newFloatArrayZh_fast); -EF_(newDoubleArrayZh_fast); -EF_(newStablePtrArrayZh_fast); -EF_(newArrayZh_fast); +EF_(newCharArrayzh_fast); +EF_(newIntArrayzh_fast); +EF_(newWordArrayzh_fast); +EF_(newAddrArrayzh_fast); +EF_(newFloatArrayzh_fast); +EF_(newDoubleArrayzh_fast); +EF_(newStablePtrArrayzh_fast); +EF_(newArrayzh_fast); /* encoding and decoding of floats/doubles. */ @@ -539,9 +538,9 @@ EF_(newArrayZh_fast); #include "ieee-flpt.h" #if FLOATS_AS_DOUBLES /* i.e. 64-bit machines */ -#define encodeFloatZh(r, aa,sa,da, expon) encodeDoubleZh(r, aa,sa,da, expon) +#define encodeFloatzh(r, aa,sa,da, expon) encodeDoublezh(r, aa,sa,da, expon) #else -#define encodeFloatZh(r, aa,sa,da, expon) \ +#define encodeFloatzh(r, aa,sa,da, expon) \ { MP_INT arg; \ /* Does not allocate memory */ \ \ @@ -553,7 +552,7 @@ EF_(newArrayZh_fast); } #endif /* FLOATS_AS_DOUBLES */ -#define encodeDoubleZh(r, aa,sa,da, expon) \ +#define encodeDoublezh(r, aa,sa,da, expon) \ { MP_INT arg; \ /* Does not allocate memory */ \ \ @@ -569,12 +568,12 @@ EF_(newArrayZh_fast); */ #ifdef FLOATS_AS_DOUBLES -#define decodeFloatZh_fast decodeDoubleZh_fast +#define decodeFloatzh_fast decodeDoublezh_fast #else -EF_(decodeFloatZh_fast); +EF_(decodeFloatzh_fast); #endif -EF_(decodeDoubleZh_fast); +EF_(decodeDoublezh_fast); /* grimy low-level support functions defined in StgPrimFloat.c */ @@ -597,25 +596,25 @@ extern StgInt isFloatNegativeZero(StgFloat f); newMutVar is out of line. -------------------------------------------------------------------------- */ -EF_(newMutVarZh_fast); +EF_(newMutVarzh_fast); -#define readMutVarZh(r,a) r=(P_)(((StgMutVar *)(a))->var) -#define writeMutVarZh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) -#define sameMutVarZh(r,a,b) r=(I_)((a)==(b)) +#define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var) +#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v) +#define sameMutVarzh(r,a,b) r=(I_)((a)==(b)) /* ----------------------------------------------------------------------------- MVar PrimOps. All out of line, because they either allocate or may block. -------------------------------------------------------------------------- */ - -#define sameMVarZh(r,a,b) r=(I_)((a)==(b)) +#define sameMVarzh(r,a,b) r=(I_)((a)==(b)) /* Assume external decl of EMPTY_MVAR_info is in scope by now */ -#define isEmptyMVarZh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info ) -EF_(newMVarZh_fast); -EF_(takeMVarZh_fast); -EF_(putMVarZh_fast); +#define isEmptyMVarzh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info ) +EF_(newMVarzh_fast); +EF_(takeMVarzh_fast); +EF_(putMVarzh_fast); + /* ----------------------------------------------------------------------------- Delay/Wait PrimOps @@ -627,8 +626,8 @@ EF_(putMVarZh_fast); Primitive I/O, error-handling PrimOps -------------------------------------------------------------------------- */ -EF_(catchZh_fast); -EF_(raiseZh_fast); +EF_(catchzh_fast); +EF_(raisezh_fast); extern void stg_exit(I_ n) __attribute__ ((noreturn)); @@ -638,22 +637,22 @@ extern void stg_exit(I_ n) __attribute__ ((noreturn)); #ifndef PAR -EF_(makeStableNameZh_fast); +EF_(makeStableNamezh_fast); -#define stableNameToIntZh(r,s) (r = ((StgStableName *)s)->sn) +#define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -#define eqStableNameZh(r,sn1,sn2) \ +#define eqStableNamezh(r,sn1,sn2) \ (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -#define makeStablePtrZh(r,a) \ +#define makeStablePtrzh(r,a) \ r = RET_STGCALL1(StgStablePtr,getStablePtr,a) -#define deRefStablePtrZh(r,sp) do { \ +#define deRefStablePtrzh(r,sp) do { \ ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0); \ r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \ } while (0); -#define eqStablePtrZh(r,sp1,sp2) \ +#define eqStablePtrzh(r,sp1,sp2) \ (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK))) #endif @@ -662,9 +661,9 @@ EF_(makeStableNameZh_fast); Parallel PrimOps. -------------------------------------------------------------------------- */ -EF_(forkZh_fast); -EF_(killThreadZh_fast); -EF_(seqZh_fast); +EF_(forkzh_fast); +EF_(killThreadzh_fast); +EF_(seqzh_fast); /* Hmm, I'll think about these later. */ /* ----------------------------------------------------------------------------- @@ -677,7 +676,7 @@ EF_(seqZh_fast); ToDo: follow indirections. */ -#define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b)) +#define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b)) /* ----------------------------------------------------------------------------- Weak Pointer PrimOps. @@ -685,9 +684,9 @@ EF_(seqZh_fast); #ifndef PAR -EF_(mkWeakZh_fast); -EF_(deRefWeakZh_fast); -#define sameWeakZh(w1,w2) ((w1)==(w2)) +EF_(mkWeakzh_fast); +EF_(deRefWeakzh_fast); +#define sameWeakzh(w1,w2) ((w1)==(w2)) #endif @@ -699,9 +698,9 @@ EF_(deRefWeakZh_fast); #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data) -EF_(makeForeignObjZh_fast); +EF_(makeForeignObjzh_fast); -#define writeForeignObjZh(res,datum) \ +#define writeForeignObjzh(res,datum) \ (ForeignObj_CLOSURE_DATA(res) = (P_)(datum)) #define eqForeignObj(f1,f2) ((f1)==(f2)) diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index e755fdd72f..42ebbc2a75 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:28:09 $ + * $Revision: 1.3 $ + * $Date: 1999/01/27 14:51:16 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -632,42 +632,42 @@ AsmVar asmBox( AsmBCO bco, AsmRep rep ) switch (rep) { case CHAR_REP: asmInstr(bco,i_PACK_CHAR); - grabHpNonUpd(bco,CZh_sizeW); + grabHpNonUpd(bco,Czh_sizeW); break; case INT_REP: asmInstr(bco,i_PACK_INT); - grabHpNonUpd(bco,IZh_sizeW); + grabHpNonUpd(bco,Izh_sizeW); break; #ifdef PROVIDE_INT64 case INT64_REP: asmInstr(bco,i_PACK_INT64); - grabHpNonUpd(bco,I64Zh_sizeW); + grabHpNonUpd(bco,I64zh_sizeW); break; #endif #ifdef PROVIDE_WORD case WORD_REP: asmInstr(bco,i_PACK_WORD); - grabHpNonUpd(bco,WZh_sizeW); + grabHpNonUpd(bco,Wzh_sizeW); break; #endif #ifdef PROVIDE_ADDR case ADDR_REP: asmInstr(bco,i_PACK_ADDR); - grabHpNonUpd(bco,AZh_sizeW); + grabHpNonUpd(bco,Azh_sizeW); break; #endif case FLOAT_REP: asmInstr(bco,i_PACK_FLOAT); - grabHpNonUpd(bco,FZh_sizeW); + grabHpNonUpd(bco,Fzh_sizeW); break; case DOUBLE_REP: asmInstr(bco,i_PACK_DOUBLE); - grabHpNonUpd(bco,DZh_sizeW); + grabHpNonUpd(bco,Dzh_sizeW); break; #ifdef PROVIDE_STABLE case STABLE_REP: asmInstr(bco,i_PACK_STABLE); - grabHpNonUpd(bco,StableZh_sizeW); + grabHpNonUpd(bco,Stablezh_sizeW); break; #endif diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index e99a1498d7..36b77edc73 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/01/26 11:12:41 $ + * $Revision: 1.5 $ + * $Date: 1999/01/27 14:51:18 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -320,7 +320,7 @@ static inline StgPtr grabHpNonUpd( nat size ) /* -------------------------------------------------------------------------- * Manipulate "update frame" list: * o Update frames (based on stg_do_update and friends in Updates.hc) - * o Error handling/catching (based on catchZh_fast and friends in Prims.hc) + * o Error handling/catching (based on catchzh_fast and friends in Prims.hc) * o Seq frames (based on seq_frame_entry in Prims.hc) * o Stop frames * ------------------------------------------------------------------------*/ @@ -1340,8 +1340,8 @@ enterLoop: } case i_PACK_INT: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(IZh_sizeW)); - SET_HDR(o,&IZh_con_info,??); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Izh_sizeW)); + SET_HDR(o,&Izh_con_info,??); payloadWord(o,0) = PopTaggedInt(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); @@ -1385,8 +1385,8 @@ enterLoop: } case i_PACK_INT64: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64Zh_sizeW)); - SET_HDR(o,&I64Zh_con_info,??); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64zh_sizeW)); + SET_HDR(o,&I64zh_con_info,??); ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64()); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); @@ -1436,9 +1436,9 @@ enterLoop: } case i_PACK_WORD: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(WZh_sizeW)); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Wzh_sizeW)); - SET_HDR(o,&WZh_con_info,??); + SET_HDR(o,&Wzh_con_info,??); payloadWord(o,0) = PopTaggedWord(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); @@ -1473,8 +1473,8 @@ enterLoop: } case i_PACK_ADDR: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(AZh_sizeW)); - SET_HDR(o,&AZh_con_info,??); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Azh_sizeW)); + SET_HDR(o,&Azh_con_info,??); payloadPtr(o,0) = PopTaggedAddr(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); @@ -1508,8 +1508,8 @@ enterLoop: } case i_PACK_CHAR: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(CZh_sizeW)); - SET_HDR(o,&CZh_con_info,??); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Czh_sizeW)); + SET_HDR(o,&Czh_con_info,??); payloadWord(o,0) = PopTaggedChar(); PushPtr(stgCast(StgPtr,o)); IF_DEBUG(evaluator, @@ -1542,8 +1542,8 @@ enterLoop: } case i_PACK_FLOAT: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(FZh_sizeW)); - SET_HDR(o,&FZh_con_info,??); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Fzh_sizeW)); + SET_HDR(o,&Fzh_con_info,??); ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat()); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); @@ -1576,8 +1576,8 @@ enterLoop: } case i_PACK_DOUBLE: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(DZh_sizeW)); - SET_HDR(o,&DZh_con_info,??); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Dzh_sizeW)); + SET_HDR(o,&Dzh_con_info,??); ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble()); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); @@ -1606,7 +1606,7 @@ enterLoop: } case i_PACK_STABLE: { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(StableZh_sizeW)); + StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Stablezh_sizeW)); SET_HDR(o,&StablePtr_con_info,??); payloadWord(o,0) = PopTaggedStablePtr(); IF_DEBUG(evaluator, @@ -1834,35 +1834,35 @@ enterLoop: case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */ case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */ - case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break; - case i_readCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break; - case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrZh(x,y,z)); break; + case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; + case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; + case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break; - case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break; - case i_readIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break; - case i_writeIntOffAddr: OP_AII_(writeIntOffAddrZh(x,y,z)); break; + case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break; + case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break; + case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break; #ifdef PROVIDE_INT64 - case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break; - case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break; - case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrZh(x,y,z)); break; + case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrzh(r,x,y)); break; + case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrzh(r,x,y)); break; + case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrzh(x,y,z)); break; #endif - case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break; - case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break; - case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrZh(x,y,z)); break; + case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break; + case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break; + case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break; - case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break; - case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break; - case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrZh(x,y,z)); break; + case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break; + case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break; + case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break; - case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break; - case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break; - case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrZh(x,y,z)); break; + case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break; + case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break; + case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break; #ifdef PROVIDE_STABLE - case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break; - case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break; - case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrZh(x,y,z)); break; + case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break; + case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break; + case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break; #endif #endif /* PROVIDE_ADDR */ @@ -2263,35 +2263,35 @@ enterLoop: /* Most of these generate alignment warnings on Sparcs and similar architectures. * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. */ - case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayZh(r,x,i)); break; - case i_readCharArray: OP_mI_ty(Char,"readCharArray", readCharArrayZh(r,x,i)); break; - case i_writeCharArray: OP_mIty_(Char,"writeCharArray", writeCharArrayZh(x,i,z)); break; + case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; + case i_readCharArray: OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break; + case i_writeCharArray: OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break; - case i_indexIntArray: OP_mI_ty(Int,"indexIntArray", indexIntArrayZh(r,x,i)); break; - case i_readIntArray: OP_mI_ty(Int,"readIntArray", readIntArrayZh(r,x,i)); break; - case i_writeIntArray: OP_mIty_(Int,"writeIntArray", writeIntArrayZh(x,i,z)); break; + case i_indexIntArray: OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break; + case i_readIntArray: OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break; + case i_writeIntArray: OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break; #ifdef PROVIDE_INT64 - case i_indexInt64Array: OP_mI_ty(Int64,"indexInt64Array", indexInt64ArrayZh(r,x,i)); break; - case i_readInt64Array: OP_mI_ty(Int64,"readInt64Array", readInt64ArrayZh(r,x,i)); break; - case i_writeInt64Array: OP_mIty_(Int64,"writeInt64Array", writeInt64ArrayZh(x,i,z)); break; + case i_indexInt64Array: OP_mI_ty(Int64,"indexInt64Array", indexInt64Arrayzh(r,x,i)); break; + case i_readInt64Array: OP_mI_ty(Int64,"readInt64Array", readInt64Arrayzh(r,x,i)); break; + case i_writeInt64Array: OP_mIty_(Int64,"writeInt64Array", writeInt64Arrayzh(x,i,z)); break; #endif #ifdef PROVIDE_ADDR - case i_indexAddrArray: OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayZh(r,x,i)); break; - case i_readAddrArray: OP_mI_ty(Addr,"readAddrArray", readAddrArrayZh(r,x,i)); break; - case i_writeAddrArray: OP_mIty_(Addr,"writeAddrArray", writeAddrArrayZh(x,i,z)); break; + case i_indexAddrArray: OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break; + case i_readAddrArray: OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break; + case i_writeAddrArray: OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break; #endif - case i_indexFloatArray: OP_mI_ty(Float,"indexFloatArray", indexFloatArrayZh(r,x,i)); break; - case i_readFloatArray: OP_mI_ty(Float,"readFloatArray", readFloatArrayZh(r,x,i)); break; - case i_writeFloatArray: OP_mIty_(Float,"writeFloatArray", writeFloatArrayZh(x,i,z)); break; + case i_indexFloatArray: OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break; + case i_readFloatArray: OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break; + case i_writeFloatArray: OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break; - case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayZh(r,x,i)); break; - case i_readDoubleArray: OP_mI_ty(Double,"readDoubleArray", readDoubleArrayZh(r,x,i)); break; - case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayZh(x,i,z)); break; + case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break; + case i_readDoubleArray: OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break; + case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; #ifdef PROVIDE_STABLE - case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayZh(r,x,i)); break; - case i_readStableArray: OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayZh(r,x,i)); break; - case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayZh(x,i,z)); break; + case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; + case i_readStableArray: OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break; + case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; #endif #endif /* PROVIDE_ARRAY */ diff --git a/ghc/rts/Evaluator.h b/ghc/rts/Evaluator.h index 05b4a108d3..3f9d735849 100644 --- a/ghc/rts/Evaluator.h +++ b/ghc/rts/Evaluator.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Evaluator.h,v 1.2 1998/12/02 13:28:21 simonm Exp $ + * $Id: Evaluator.h,v 1.3 1999/01/27 14:51:20 simonpj Exp $ * * Prototypes for functions in Evaluator.c * @@ -10,15 +10,15 @@ * (used by Assembler) * ------------------------------------------------------------------------*/ -#define IZh_sizeW CONSTR_sizeW(0,sizeofW(StgInt)) -#define I64Zh_sizeW CONSTR_sizeW(0,sizeofW(StgInt64)) -#define WZh_sizeW CONSTR_sizeW(0,sizeofW(StgWord)) -#define AZh_sizeW CONSTR_sizeW(0,sizeofW(StgAddr)) -#define CZh_sizeW CONSTR_sizeW(0,sizeofW(StgWord)) -#define FZh_sizeW CONSTR_sizeW(0,sizeofW(StgFloat)) -#define DZh_sizeW CONSTR_sizeW(0,sizeofW(StgDouble)) -#define StableZh_sizeW CONSTR_sizeW(0,sizeofW(StgStablePtr)) -#define GenericZh_sizeW CONSTR_sizeW(1,0) +#define Izh_sizeW CONSTR_sizeW(0,sizeofW(StgInt)) +#define I64zh_sizeW CONSTR_sizeW(0,sizeofW(StgInt64)) +#define Wzh_sizeW CONSTR_sizeW(0,sizeofW(StgWord)) +#define Azh_sizeW CONSTR_sizeW(0,sizeofW(StgAddr)) +#define Czh_sizeW CONSTR_sizeW(0,sizeofW(StgWord)) +#define Fzh_sizeW CONSTR_sizeW(0,sizeofW(StgFloat)) +#define Dzh_sizeW CONSTR_sizeW(0,sizeofW(StgDouble)) +#define Stablezh_sizeW CONSTR_sizeW(0,sizeofW(StgStablePtr)) +#define Genericzh_sizeW CONSTR_sizeW(1,0) /* -------------------------------------------------------------------------- * diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 784c6a1676..cfcca50338 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.8 1999/01/26 16:16:25 simonm Exp $ + * $Id: PrimOps.hc,v 1.9 1999/01/27 14:51:20 simonpj Exp $ * * Primitive functions / data * @@ -26,8 +26,8 @@ for these. */ -W_ GHC_ZcCCallable_static_info[0]; -W_ GHC_ZcCReturnable_static_info[0]; +W_ GHC_ZCCCallable_static_info[0]; +W_ GHC_ZCCReturnable_static_info[0]; #ifndef aix_TARGET_OS /* AIX gives link errors with this as a const (RO assembler section) */ const @@ -186,12 +186,12 @@ const #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_) #define newByteArray(ty,scale) \ - FN_(new##ty##ArrayZh_fast) \ + FN_(new##ty##Arrayzh_fast) \ { \ W_ stuff_size, size, n; \ StgArrWords* p; \ FB_ \ - MAYBE_GC(NO_PTRS,new##ty##ArrayZh_fast); \ + MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast); \ n = R1.w; \ stuff_size = BYTES_TO_STGWORDS(n*scale); \ size = sizeofW(StgArrWords)+ stuff_size; \ @@ -212,7 +212,7 @@ newByteArray(Float, sizeof(StgFloat)); newByteArray(Double, sizeof(StgDouble)); newByteArray(StablePtr, sizeof(StgStablePtr)); -FN_(newArrayZh_fast) +FN_(newArrayzh_fast) { W_ size, n, init; StgMutArrPtrs* arr; @@ -220,7 +220,7 @@ FN_(newArrayZh_fast) FB_ n = R1.w; - MAYBE_GC(R2_PTR,newArrayZh_fast); + MAYBE_GC(R2_PTR,newArrayzh_fast); size = sizeofW(StgMutArrPtrs) + n; arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size); @@ -240,13 +240,13 @@ FN_(newArrayZh_fast) FE_ } -FN_(newMutVarZh_fast) +FN_(newMutVarzh_fast) { StgMutVar* mv; /* Args: R1.p = initialisation value */ FB_ - HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarZh_fast,); + HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,); TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */ CCS_ALLOC(CCCS,sizeofW(StgMutVar)); @@ -265,14 +265,14 @@ FN_(newMutVarZh_fast) -------------------------------------------------------------------------- */ #ifndef PAR -FN_(makeForeignObjZh_fast) +FN_(makeForeignObjzh_fast) { /* R1.p = ptr to foreign object, */ StgForeignObj *result; FB_ - HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjZh_fast,); + HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,); TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgForeignObj)-sizeofW(StgHeader), 0); CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */ @@ -294,7 +294,7 @@ FN_(makeForeignObjZh_fast) #ifndef PAR -FN_(mkWeakZh_fast) +FN_(mkWeakzh_fast) { /* R1.p = key R2.p = value @@ -303,7 +303,7 @@ FN_(mkWeakZh_fast) StgWeak *w; FB_ - HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakZh_fast,); + HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,); TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0); CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */ @@ -324,7 +324,7 @@ FN_(mkWeakZh_fast) FE_ } -FN_(deRefWeakZh_fast) +FN_(deRefWeakzh_fast) { /* R1.p = weak ptr */ @@ -347,7 +347,7 @@ FN_(deRefWeakZh_fast) Arbitrary-precision Integer operations. -------------------------------------------------------------------------- */ -FN_(int2IntegerZh_fast) +FN_(int2Integerzh_fast) { /* arguments: R1 = Int# */ @@ -356,7 +356,7 @@ FN_(int2IntegerZh_fast) FB_ val = R1.i; - HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2IntegerZh_fast,); + HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,); TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0); CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */ @@ -384,7 +384,7 @@ FN_(int2IntegerZh_fast) FE_ } -FN_(word2IntegerZh_fast) +FN_(word2Integerzh_fast) { /* arguments: R1 = Word# */ @@ -394,7 +394,7 @@ FN_(word2IntegerZh_fast) FB_ val = R1.w; - HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2IntegerZh_fast,) + HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,) TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0); CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */ @@ -418,13 +418,13 @@ FN_(word2IntegerZh_fast) FE_ } -FN_(addr2IntegerZh_fast) +FN_(addr2Integerzh_fast) { MP_INT result; char *str; FB_ - MAYBE_GC(NO_PTRS,addr2IntegerZh_fast); + MAYBE_GC(NO_PTRS,addr2Integerzh_fast); /* args: R1 :: Addr# */ str = R1.a; @@ -445,7 +445,7 @@ FN_(addr2IntegerZh_fast) #ifdef SUPPORT_LONG_LONGS -FN_(int64ToIntegerZh_fast) +FN_(int64ToIntegerzh_fast) { /* arguments: L1 = Int64# */ @@ -464,7 +464,7 @@ FN_(int64ToIntegerZh_fast) /* minimum is one word */ words_needed = 1; } - HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerZh_fast,) + HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,) TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0); CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */ @@ -502,7 +502,7 @@ FN_(int64ToIntegerZh_fast) FE_ } -FN_(word64ToIntegerZh_fast) +FN_(word64ToIntegerzh_fast) { /* arguments: L1 = Word64# */ @@ -518,7 +518,7 @@ FN_(word64ToIntegerZh_fast) } else { words_needed = 1; } - HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerZh_fast,) + HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,) TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0); CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */ @@ -634,16 +634,16 @@ FN_(name) \ FE_ \ } -GMP_TAKE2_RET1(plusIntegerZh_fast, mpz_add); -GMP_TAKE2_RET1(minusIntegerZh_fast, mpz_sub); -GMP_TAKE2_RET1(timesIntegerZh_fast, mpz_mul); -GMP_TAKE2_RET1(gcdIntegerZh_fast, mpz_gcd); +GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add); +GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub); +GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul); +GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd); -GMP_TAKE2_RET2(quotRemIntegerZh_fast, mpz_tdiv_qr); -GMP_TAKE2_RET2(divModIntegerZh_fast, mpz_fdiv_qr); +GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr); +GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr); #ifndef FLOATS_AS_DOUBLES -FN_(decodeFloatZh_fast) +FN_(decodeFloatzh_fast) { MP_INT mantissa; I_ exponent; @@ -654,7 +654,7 @@ FN_(decodeFloatZh_fast) /* arguments: F1 = Float# */ arg = F1; - HP_CHK_GEN(sizeof(StgArrWords)+1, NO_PTRS, decodeFloatZh_fast,); + HP_CHK_GEN(sizeof(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,); TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0); CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */ @@ -677,7 +677,7 @@ FN_(decodeFloatZh_fast) #define DOUBLE_MANTISSA_SIZE (sizeof(StgDouble)/sizeof(W_)) #define ARR_SIZE (sizeof(StgArrWords) + DOUBLE_MANTISSA_SIZE) -FN_(decodeDoubleZh_fast) +FN_(decodeDoublezh_fast) { MP_INT mantissa; I_ exponent; StgDouble arg; @@ -687,7 +687,7 @@ FN_(decodeDoubleZh_fast) /* arguments: D1 = Double# */ arg = D1; - HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoubleZh_fast,); + HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,); TICK_ALLOC_PRIM(sizeof(StgArrWords),DOUBLE_MANTISSA_SIZE,0); CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */ @@ -710,14 +710,14 @@ FN_(decodeDoubleZh_fast) * Concurrency primitives * -------------------------------------------------------------------------- */ -FN_(forkZh_fast) +FN_(forkzh_fast) { FB_ /* args: R1 = closure to spark */ if (closure_SHOULD_SPARK(stgCast(StgClosure*,R1.p))) { - MAYBE_GC(R1_PTR, forkZh_fast); + MAYBE_GC(R1_PTR, forkzh_fast); /* create it right now, return ThreadID in R1 */ R1.t = RET_STGCALL2(StgTSO *, createIOThread, @@ -731,7 +731,7 @@ FN_(forkZh_fast) FE_ } -FN_(killThreadZh_fast) +FN_(killThreadzh_fast) { FB_ /* args: R1.p = TSO to kill */ @@ -752,14 +752,14 @@ FN_(killThreadZh_fast) FE_ } -FN_(newMVarZh_fast) +FN_(newMVarzh_fast) { StgMVar *mvar; FB_ /* args: none */ - HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarZh_fast,); + HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,); TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds 1, 0); CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */ @@ -774,7 +774,7 @@ FN_(newMVarZh_fast) FE_ } -FN_(takeMVarZh_fast) +FN_(takeMVarzh_fast) { StgMVar *mvar; StgClosure *val; @@ -796,7 +796,7 @@ FN_(takeMVarZh_fast) CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure; mvar->tail = CurrentTSO; - BLOCK(R1_PTR, takeMVarZh_fast); + BLOCK(R1_PTR, takeMVarzh_fast); } SET_INFO(mvar,&EMPTY_MVAR_info); @@ -808,7 +808,7 @@ FN_(takeMVarZh_fast) FE_ } -FN_(putMVarZh_fast) +FN_(putMVarzh_fast) { StgMVar *mvar; StgTSO *tso; @@ -849,13 +849,13 @@ FN_(putMVarZh_fast) Stable pointer primitives ------------------------------------------------------------------------- */ -FN_(makeStableNameZh_fast) +FN_(makeStableNamezh_fast) { StgWord index; StgStableName *sn_obj; FB_ - HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNameZh_fast,); + HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,); TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgStableName)-sizeofW(StgHeader), 0); CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */ diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 2ae69a98c5..4cc976d7b0 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.c,v 1.2 1998/12/02 13:28:38 simonm Exp $ + * $Id: RtsAPI.c,v 1.3 1999/01/27 14:51:21 simonpj Exp $ * * API for invoking Haskell functions via the RTS * @@ -18,7 +18,7 @@ HaskellObj rts_mkChar (char c) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &CZh_con_info; + p->header.info = &Czh_con_info; p->payload[0] = (StgClosure *)((StgInt)c); return p; } @@ -27,7 +27,7 @@ HaskellObj rts_mkInt (int i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &IZh_con_info; + p->header.info = &Izh_con_info; p->payload[0] = (StgClosure *)(StgInt)i; return p; } @@ -40,7 +40,7 @@ rts_mkInt8 (int i) instead of the one for Int8, but the types have identical representation. */ - p->header.info = &IZh_con_info; + p->header.info = &Izh_con_info; /* Make sure we mask out the bits above the lowest 8 */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff); return p; @@ -54,7 +54,7 @@ rts_mkInt16 (int i) instead of the one for Int8, but the types have identical representation. */ - p->header.info = &IZh_con_info; + p->header.info = &Izh_con_info; /* Make sure we mask out the relevant bits */ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff); return p; @@ -65,7 +65,7 @@ rts_mkInt32 (int i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); /* see mk_Int8 comment */ - p->header.info = &IZh_con_info; + p->header.info = &Izh_con_info; p->payload[0] = (StgClosure *)(StgInt)i; return p; } @@ -76,7 +76,7 @@ rts_mkInt64 (long long int i) long long *tmp; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); /* see mk_Int8 comment */ - p->header.info = &I64Zh_con_info; + p->header.info = &I64zh_con_info; tmp = (long long*)&(p->payload[0]); *tmp = (StgInt64)i; return p; @@ -86,7 +86,7 @@ HaskellObj rts_mkWord (unsigned int i) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &WZh_con_info; + p->header.info = &Wzh_con_info; p->payload[0] = (StgClosure *)(StgWord)i; return p; } @@ -96,7 +96,7 @@ rts_mkWord8 (unsigned int w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &WZh_con_info; + p->header.info = &Wzh_con_info; p->payload[0] = (StgClosure *)(StgWord)(w & 0xff); return p; } @@ -106,7 +106,7 @@ rts_mkWord16 (unsigned int w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &WZh_con_info; + p->header.info = &Wzh_con_info; p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff); return p; } @@ -116,7 +116,7 @@ rts_mkWord32 (unsigned int w) { /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &WZh_con_info; + p->header.info = &Wzh_con_info; p->payload[0] = (StgClosure *)(StgWord)w; return p; } @@ -125,11 +125,11 @@ HaskellObj rts_mkWord64 (unsigned long long w) { unsigned long long *tmp; - extern StgInfoTable W64Zh_con_info; + extern StgInfoTable W64zh_con_info; StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2)); /* see mk_Int8 comment */ - p->header.info = &W64Zh_con_info; + p->header.info = &W64zh_con_info; tmp = (unsigned long long*)&(p->payload[0]); *tmp = (StgNat64)w; return p; @@ -139,7 +139,7 @@ HaskellObj rts_mkFloat (float f) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); - p->header.info = &FZh_con_info; + p->header.info = &Fzh_con_info; ASSIGN_FLT((P_)p->payload, (StgFloat)f); return p; } @@ -148,7 +148,7 @@ HaskellObj rts_mkDouble (double d) { StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble))); - p->header.info = &DZh_con_info; + p->header.info = &Dzh_con_info; ASSIGN_DBL((P_)p->payload, (StgDouble)d); return p; } @@ -166,7 +166,7 @@ HaskellObj rts_mkAddr (void *a) { StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1); - p->header.info = &AZh_con_info; + p->header.info = &Azh_con_info; p->payload[0] = (StgClosure *)a; return p; } @@ -207,7 +207,7 @@ rts_apply (HaskellObj f, HaskellObj arg) char rts_getChar (HaskellObj p) { - if (p->header.info == &CZh_con_info || p->header.info == &CZh_static_info) { + if (p->header.info == &Czh_con_info || p->header.info == &Czh_static_info) { return (char)(StgWord)(p->payload[0]); } else { barf("getChar: not a Char"); @@ -217,7 +217,7 @@ rts_getChar (HaskellObj p) int rts_getInt (HaskellObj p) { - if (p->header.info == &IZh_con_info || p->header.info == &IZh_static_info) { + if (p->header.info == &Izh_con_info || p->header.info == &Izh_static_info) { return (int)(p->payload[0]); } else { barf("getInt: not an Int"); @@ -227,7 +227,7 @@ rts_getInt (HaskellObj p) unsigned int rts_getWord (HaskellObj p) { - if (p->header.info == &WZh_con_info || p->header.info == &WZh_static_info) { + if (p->header.info == &Wzh_con_info || p->header.info == &Wzh_static_info) { return (unsigned int)(p->payload[0]); } else { barf("getWord: not a Word"); @@ -237,7 +237,7 @@ rts_getWord (HaskellObj p) float rts_getFloat (HaskellObj p) { - if (p->header.info == &FZh_con_info || p->header.info == &FZh_static_info) { + if (p->header.info == &Fzh_con_info || p->header.info == &Fzh_static_info) { return (float)(PK_FLT((P_)p->payload)); } else { barf("getFloat: not a Float"); @@ -247,7 +247,7 @@ rts_getFloat (HaskellObj p) double rts_getDouble (HaskellObj p) { - if (p->header.info == &DZh_con_info || p->header.info == &DZh_static_info) { + if (p->header.info == &Dzh_con_info || p->header.info == &Dzh_static_info) { return (double)(PK_DBL((P_)p->payload)); } else { barf("getDouble: not a Double"); @@ -268,7 +268,7 @@ rts_getStablePtr (HaskellObj p) void * rts_getAddr (HaskellObj p) { - if (p->header.info == &AZh_con_info || p->header.info == &AZh_static_info) { + if (p->header.info == &Azh_con_info || p->header.info == &Azh_static_info) { return (void *)(p->payload[0]); } else { barf("getAddr: not an Addr"); diff --git a/ghc/rts/RtsUtils.c b/ghc/rts/RtsUtils.c index 2ed09d3315..4361952344 100644 --- a/ghc/rts/RtsUtils.c +++ b/ghc/rts/RtsUtils.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: RtsUtils.c,v 1.3 1999/01/21 10:31:49 simonm Exp $ + * $Id: RtsUtils.c,v 1.4 1999/01/27 14:51:21 simonpj Exp $ * * General utility functions used in the RTS. * @@ -160,12 +160,12 @@ nat stg_strlen(char *s) I_ __GenSymCounter = 0; I_ -genSymZh(void) +genSymzh(void) { return(__GenSymCounter++); } I_ -resetGenSymZh(void) /* it's your funeral */ +resetGenSymzh(void) /* it's your funeral */ { __GenSymCounter=0; return(__GenSymCounter); diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 9bc0930131..a5111137a0 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.hc,v 1.8 1999/01/26 11:12:52 simonm Exp $ + * $Id: StgMiscClosures.hc,v 1.9 1999/01/27 14:51:22 simonpj Exp $ * * Entry code for various built-in closure types. * @@ -407,25 +407,25 @@ VEC_POLY_INFO_TABLE(ret_bco,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO) #ifndef COMPILER -INFO_TABLE_CONSTR(CZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR,const,EF_,0,0); -INFO_TABLE_CONSTR(IZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR,const,EF_,0,0); -INFO_TABLE_CONSTR(I64Zh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR,const,EF_,0,0); -INFO_TABLE_CONSTR(FZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR,const,EF_,0,0); -INFO_TABLE_CONSTR(DZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR,const,EF_,0,0); -INFO_TABLE_CONSTR(AZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR,const,EF_,0,0); -INFO_TABLE_CONSTR(WZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(Czh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(Izh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(I64zh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(Fzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(Dzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(Azh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR,const,EF_,0,0); +INFO_TABLE_CONSTR(Wzh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR,const,EF_,0,0); INFO_TABLE_CONSTR(StablePtr_con_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR,const,EF_,0,0); -/* These might seem redundant but {I,C}Zh_static_info are used in +/* These might seem redundant but {I,C}zh_static_info are used in * {INT,CHAR}LIKE and the rest are used in RtsAPI.c */ -INFO_TABLE_CONSTR(CZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); -INFO_TABLE_CONSTR(IZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); -INFO_TABLE_CONSTR(I64Zh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); -INFO_TABLE_CONSTR(FZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); -INFO_TABLE_CONSTR(DZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); -INFO_TABLE_CONSTR(AZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); -INFO_TABLE_CONSTR(WZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(Czh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(Izh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(I64zh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(Fzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(Dzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(Azh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); +INFO_TABLE_CONSTR(Wzh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); INFO_TABLE_CONSTR(StablePtr_static_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0); #endif /* !defined(COMPILER) */ @@ -440,14 +440,14 @@ INFO_TABLE_CONSTR(StablePtr_static_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr #define CHARLIKE_HDR(n) \ { \ - STATIC_HDR(CZh_static_info, /* C# */ \ + STATIC_HDR(Czh_static_info, /* C# */ \ CCS_DONTZuCARE), \ data : n \ } #define INTLIKE_HDR(n) \ { \ - STATIC_HDR(IZh_static_info, /* I# */ \ + STATIC_HDR(Izh_static_info, /* I# */ \ CCS_DONTZuCARE), \ data : n \ } diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc index cbebe92abf..8fc0fae7ed 100644 --- a/ghc/rts/Updates.hc +++ b/ghc/rts/Updates.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Updates.hc,v 1.7 1999/01/21 10:31:53 simonm Exp $ + * $Id: Updates.hc,v 1.8 1999/01/27 14:51:23 simonpj Exp $ * * Code to perform updates. * @@ -501,8 +501,8 @@ STGFUN(seq_entry) Exception Primitives -------------------------------------------------------------------------- */ -FN_(catchZh_fast); -FN_(raiseZh_fast); +FN_(catchzh_fast); +FN_(raisezh_fast); #define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \ FN_(label); \ @@ -554,17 +554,17 @@ STGFUN(catch_entry) FB_ R2.cl = payloadCPtr(R1.cl,1); /* h */ R1.cl = payloadCPtr(R1.cl,0); /* x */ - JMP_(catchZh_fast); + JMP_(catchzh_fast); FE_ } -FN_(catchZh_fast) +FN_(catchzh_fast) { StgCatchFrame *fp; FB_ /* args: R1 = m, R2 = k */ - STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchZh_fast, ); + STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchzh_fast, ); Sp -= sizeofW(StgCatchFrame); fp = (StgCatchFrame *)Sp; SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS); @@ -585,7 +585,7 @@ FN_(catchZh_fast) * * raise = {err} \n {} -> raise#{err} * - * It is used in raiseZh_fast to update thunks on the update list + * It is used in raisezh_fast to update thunks on the update list * -------------------------------------------------------------------------- */ INFO_TABLE(raise_info,raise_entry,1,0,FUN,const,EF_,0,0); @@ -593,11 +593,11 @@ STGFUN(raise_entry) { FB_ R1.cl = R1.cl->payload[0]; - JMP_(raiseZh_fast); + JMP_(raisezh_fast); FE_ } -FN_(raiseZh_fast) +FN_(raisezh_fast) { StgClosure *handler; StgUpdateFrame *p; @@ -634,10 +634,10 @@ FN_(raiseZh_fast) break; case STOP_FRAME: - barf("raiseZh_fast: STOP_FRAME"); + barf("raisezh_fast: STOP_FRAME"); default: - barf("raiseZh_fast: weird activation record"); + barf("raisezh_fast: weird activation record"); } break; |