Version, Arity,
Unused, unused,
Fixity(..), FixityDirection(..), StrictnessMark(..),
- NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..)
+ NewOrData(..), TopLevelFlag(..), RecFlag(..)
) where
#include "HsVersions.h"
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible,
+ setIdName, setIdUnique, setIdType, setIdInfo,
-- Predicates
omitIfaceSigForId,
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
-- 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
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}
%************************************************************************
\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
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(..) )
%************************************************************************
\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
-- 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
-- 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}
-- 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
-- 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}
\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
\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}
\begin{code}
nameUnique :: Name -> Unique
-nameModAndOcc :: Name -> (Module, OccName) -- Globals only
nameOccName :: Name -> OccName
nameModule :: Name -> Module
nameSrcLoc :: Name -> SrcLoc
-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}
%************************************************************************
\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}
-- 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
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 "-}"]
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}
\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
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}
%************************************************************************
\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}
\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}
\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}
-> 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}
-> 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}
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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
-- 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
%************************************************************************
%* *
-\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}
#include "HsVersions.h"
+import Util ( thenCmp )
import Outputable
import FastString ( unpackFS )
import GlaExts ( Int(..), (+#) )
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
%************************************************************************
\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 ->
_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 ;;
+
__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 ;
+
%
% (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 $
%
%********************************************************
%* *
\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) ->
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 )
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)
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,
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}
%************************************************************************
#include "HsVersions.h"
import CoreSyn
+import CostCentre ( pprCostCentreCore )
import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
import Var ( isTyVar )
import IdInfo ( ppIdInfo )
\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
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)
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("->")
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
| 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.
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
)
import Unique ( unboundKey )
import TyCon ( tyConDataCons )
+import SrcLoc ( noSrcLoc )
import UniqSet
import Outputable
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)
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
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}
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]
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
| 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
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,
(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.
, 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 ->
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)
ValueEnv,
dsWarn,
DsWarnings,
- DsMatchContext(..), DsMatchKind(..), pprDsWarnings
+ DsMatchContext(..), DsMatchKind(..)
) where
#include "HsVersions.h"
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
| ListCompMatch
| LetMatch
deriving ()
-
-pprDsWarnings :: DsWarnings -> SDoc
-pprDsWarnings warns = pprBagOfErrors warns
\end{code}
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
--others:
import Id ( Id )
-import Name ( OccName, NamedThing(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import Bag
\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
\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)]
= 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}
%************************************************************************
\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
= 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],
import CallConv ( CallConv, pprCallConv )
-- others:
-import Name ( NamedThing )
import Outputable
import SrcLoc ( SrcLoc )
import Util
\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
\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
#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
\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)
(HsType name)
SrcLoc
-instance (NamedThing name, Outputable name)
+instance (Outputable name)
=> Outputable (SpecDataSig name) where
ppr (SpecDataSig tycon ty _)
\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]
\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)
= DefaultDecl [HsType name]
SrcLoc
-instance (NamedThing name, Outputable name)
+instance (Outputable name)
=> Outputable (DefaultDecl name) where
ppr (DefaultDecl tys src_loc)
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)
[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)
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 ;;
import HsTypes ( HsType )
-- others:
-import Name ( Name, NamedThing(..), isSymOcc )
+import Name ( Name, isLexId )
import Outputable
import PprType ( pprType, pprParendType )
import Type ( Type )
\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)
= 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
Parenthesize unless very simple:
\begin{code}
-pprParendExpr :: (NamedThing id, Outputable id, Outputable pat)
+pprParendExpr :: (Outputable id, Outputable pat)
=> HsExpr id pat -> SDoc
pprParendExpr expr
%************************************************************************
\begin{code}
-pp_rbinds :: (NamedThing id, Outputable id, Outputable pat)
+pp_rbinds :: (Outputable id, Outputable pat)
=> SDoc
-> HsRecordBinds id pat -> SDoc
\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
\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]
#include "HsVersions.h"
-import BasicTypes ( IfaceFlavour(..) )
-import Name ( Module, NamedThing, pprModule )
+import OccName ( Module, pprModule, moduleIfaceFlavour, bootFlavour )
import Outputable
import SrcLoc ( SrcLoc )
\end{code}
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")
\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 "(..)"]
_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 ;;
__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 ;
import Type ( Type )
import SrcLoc ( SrcLoc )
import Outputable
-import Name ( NamedThing )
\end{code}
%************************************************************************
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),
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)
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)
-- 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 )
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]
module HsMatches,
module HsPat,
module HsTypes,
- Fixity, NewOrData, IfaceFlavour,
+ Fixity, NewOrData,
collectTopBinders, collectMonoBinders
) where
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.
\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
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
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
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 )
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
)
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
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)
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
\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']
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
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
{
switch(i) {
case ARROWGID:
- return(mkgid(i,install_literal("->")));
+ return(mkgid(i,install_literal("(->)")));
case NILGID:
return(mkgid(i,install_literal("[]")));
case UNITGID:
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 )
= 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
\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)
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
\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}
-- 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}
+
#include "HsVersions.h"
-import OccName ( Module, mkModule )
+import OccName ( Module, mkSrcModule )
import Util ( nOfThem )
import Panic ( panic )
\end{code}
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}
-- 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 )
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
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
)
[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:
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)
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
\begin{code}
module TysPrim(
- alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+ alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
alphaTy, betaTy, gammaTy, deltaTy,
openAlphaTyVar, openAlphaTyVars,
alphaTyVars = [ mkSysTyVar u boxedTypeKind
| u <- map mkAlphaTyVarUnique [2..] ]
+betaTyVars = tail alphaTyVars
+
alphaTyVar, betaTyVar, gammaTyVar :: TyVar
(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
-- 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 )
[ 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}
\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,
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}
= 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.
--
-- "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
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
| 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}
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
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}
-----------------------------------------------------------------------------
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 ");"
]
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
= 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}
-- 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_`
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(..) )
| ITnocaf
| ITunfold InlinePragInfo
| ITstrict ([Demand], Bool)
- | ITscc CostCentre
+ | ITscc
+ | ITsccAllCafs
+ | ITsccAllDicts
| ITdotdot -- reserved symbols
| ITdcolon
| 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}
%************************************************************************
(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
------------------
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
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
import HsSyn
import RdrHsSyn
+import RdrName ( RdrName )
import Panic ( panic )
import Char ( isDigit, ord )
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
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.
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)
\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}
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}
\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
-- 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
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 $
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!
returnUgn (MonoTyVar tyvar)
U_tname tcon -> -- type constructor
- wlkTCId tcon `thenUgn` \ tycon ->
+ wlkTcId tcon `thenUgn` \ tycon ->
returnUgn (MonoTyVar tycon)
U_tapp t1 t2 ->
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}
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}
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 ->
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}
= 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}
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 )
'__litlit' { ITlit_lit }
'__string' { ITstring_lit }
'__ccall' { ITccall $$ }
- '__scc' { ITscc $$ }
- '__a' { ITtypeapp }
+ '__scc' { ITscc }
+ '__sccC' { ITsccAllCafs }
+ '__sccD' { ITsccAllDicts }
'__A' { ITarity }
'__P' { ITspecialise }
| 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 }
| 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 : { [] }
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 }
{ 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 -} { \_ -> [] }
| 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 -} }
| 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] }
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 : { [] }
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 }
| 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] }
| 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 }
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 }
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 }
#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,
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 )
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) ->
-- 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
\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
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)
]
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 ||
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 )
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)
-- 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
-- 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
-- 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}
-- 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
) `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
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
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
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
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 ->
-- 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
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)
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}
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.
-- 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
-- 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,
-- 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
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}
=============== 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
-- 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
-- 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]
\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])
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
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
-- 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
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 $
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}
\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)])
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}
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,
| 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)
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) ->
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_`
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}
%************************************************************************
-> RnMS s ([RenamedStmt], FreeVars)
rnStmts rn_expr []
- = returnRn ([], emptyNameSet)
+ = returnRn ([], emptyFVs)
rnStmts rn_expr (stmt:stmts)
= rnStmt rn_expr stmt $ \ stmt' ->
\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}
%************************************************************************
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
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 )
\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_`
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)
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 ->
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
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.
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
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
\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
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
= 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
%*********************************************************
\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
\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 ->
\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
%*********************************************************
\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.
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")]
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
\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 ->
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)
@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))
%*********************************************************
\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
-- 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)]
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 )
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
-- 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
-- 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.
===================================================
\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
-------------------
data Ifaces = Ifaces {
- iMod :: Module, -- Name of this module
+ iMod :: Module, -- Name of the module being compiled
iModMap :: FiniteMap Module (IfaceFlavour, -- Exports
Version,
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)
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
}
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
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 ->
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) $
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])
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}
\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
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
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}
\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
\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
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 ()
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
-- 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}
\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}
\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}
#include "HsVersions.h"
import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
- opt_SourceUnchanged
+ opt_SourceUnchanged, opt_WarnUnusedBinds
)
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
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
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
| 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}
\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
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
-- (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
= 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
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
= 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)
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}
| 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}
#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' ->
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
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),
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
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 )
-- 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
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))
(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
-- (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!
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
-- 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)
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 ->
-- from interface files, which always print in prefix form
checkConName name
- = checkRn (isConOcc (rdrNameOcc name))
+ = checkRn (isRdrDataCon name)
(badDataCon name)
\end{code}
= 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)]
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 )
= -- 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'
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
= 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
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 )
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
#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 )
Name, Module, NamedThing(..),
OccName, nameOccName
)
+import RdrName ( RdrName )
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
tcLookupValueByKey, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, explicitLookupValue,
- newLocalIds, newLocalId, newSpecPragmaId,
+ newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
badCon, badPrimOp
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(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import Bag ( bagToList )
import Maybes ( maybeToBool )
+import SrcLoc ( SrcLoc )
import FastString ( FastString )
import Outputable
\end{code}
%************************************************************************
\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}
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
-- 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
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
\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")
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
\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
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(..) )
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}
)
import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon,
tyConArity )
-import Name ( isSysLocalName )
+import Name ( isSystemName )
import Var ( TyVar, tyVarKind, varName )
import VarEnv
import VarSet ( varSetElems )
-- 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
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
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
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:"))
= 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
_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 ;;
+
__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 ;
mkKindCon,
mkSuperKindCon,
+ setTyConName,
+
tyConKind,
tyConUnique,
tyConTyVars,
tyConTyVars = tyvars,
synTyConDefn = rhs
}
+
+setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name}
\end{code}
\begin{code}
-- 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
-- others
import BasicTypes ( Unused )
-import SrcLoc ( mkBuiltinSrcLoc )
+import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc )
import PrelMods ( pREL_GHC )
import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..), isFollowableRep )
| 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
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}
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
-- 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"
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
/* -----------------------------------------------------------------------------
- * $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.
*
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;
* 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
/* -----------------------------------------------------------------------------
- * $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.
*
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[];
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.
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.
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]; \
}
-
-#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]; \
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.
* to allocate any memory.
*/
-#define integer2IntZh(r, aa,sa,da) \
+#define integer2Intzh(r, aa,sa,da) \
{ MP_INT arg; \
\
arg._mp_alloc = (aa); \
(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); \
(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; \
\
* derive a better version:
*/
-#define negateIntegerZh(ra, rs, rd, a, s, d) \
+#define negateIntegerzh(ra, rs, rd, a, s, d) \
{ \
(ra) = (a); \
(rs) = -(s); \
/* 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.
#ifdef SUPPORT_LONG_LONGS
-#define integerToWord64Zh(r, aa,sa,da) \
+#define integerToWord64zh(r, aa,sa,da) \
{ unsigned long int* d; \
StgNat64 res; \
\
(r) = res; \
}
-#define integerToInt64Zh(r, aa,sa,da) \
+#define integerToInt64zh(r, aa,sa,da) \
{ unsigned long int* d; \
StgInt64 res; \
\
}
/* 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.
*/
#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
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. */
#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 */ \
\
}
#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 */ \
\
*/
#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 */
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
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));
#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
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. */
/* -----------------------------------------------------------------------------
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.
#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
#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))
* 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.
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
* 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"
/* --------------------------------------------------------------------------
* 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
* ------------------------------------------------------------------------*/
}
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 ");
}
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 ");
}
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 ");
}
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 ");
}
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,
}
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 ");
}
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 ");
}
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,
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 */
/* 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 */
/* -----------------------------------------------------------------------------
- * $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
*
* (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)
/* --------------------------------------------------------------------------
*
/* -----------------------------------------------------------------------------
- * $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
*
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
#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; \
newByteArray(Double, sizeof(StgDouble));
newByteArray(StablePtr, sizeof(StgStablePtr));
-FN_(newArrayZh_fast)
+FN_(newArrayzh_fast)
{
W_ size, n, init;
StgMutArrPtrs* arr;
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);
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));
-------------------------------------------------------------------------- */
#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 */
#ifndef PAR
-FN_(mkWeakZh_fast)
+FN_(mkWeakzh_fast)
{
/* R1.p = key
R2.p = value
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 */
FE_
}
-FN_(deRefWeakZh_fast)
+FN_(deRefWeakzh_fast)
{
/* R1.p = weak ptr
*/
Arbitrary-precision Integer operations.
-------------------------------------------------------------------------- */
-FN_(int2IntegerZh_fast)
+FN_(int2Integerzh_fast)
{
/* arguments: R1 = Int# */
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 */
FE_
}
-FN_(word2IntegerZh_fast)
+FN_(word2Integerzh_fast)
{
/* arguments: R1 = Word# */
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 */
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;
#ifdef SUPPORT_LONG_LONGS
-FN_(int64ToIntegerZh_fast)
+FN_(int64ToIntegerzh_fast)
{
/* arguments: L1 = Int64# */
/* 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 */
FE_
}
-FN_(word64ToIntegerZh_fast)
+FN_(word64ToIntegerzh_fast)
{
/* arguments: L1 = Word64# */
} 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 */
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;
/* 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 */
#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;
/* 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 */
* 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,
FE_
}
-FN_(killThreadZh_fast)
+FN_(killThreadzh_fast)
{
FB_
/* args: R1.p = TSO to kill */
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 */
FE_
}
-FN_(takeMVarZh_fast)
+FN_(takeMVarzh_fast)
{
StgMVar *mvar;
StgClosure *val;
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);
FE_
}
-FN_(putMVarZh_fast)
+FN_(putMVarzh_fast)
{
StgMVar *mvar;
StgTSO *tso;
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 */
/* ----------------------------------------------------------------------------
- * $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
*
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;
}
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;
}
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;
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;
{
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;
}
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;
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;
}
{
/* 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;
}
{
/* 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;
}
{
/* 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;
}
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;
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;
}
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;
}
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;
}
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");
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");
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");
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");
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");
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");
/* -----------------------------------------------------------------------------
- * $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.
*
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);
/* -----------------------------------------------------------------------------
- * $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.
*
#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) */
#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 \
}
/* -----------------------------------------------------------------------------
- * $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.
*
Exception Primitives
-------------------------------------------------------------------------- */
-FN_(catchZh_fast);
-FN_(raiseZh_fast);
+FN_(catchzh_fast);
+FN_(raisezh_fast);
#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
FN_(label); \
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);
*
* 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);
{
FB_
R1.cl = R1.cl->payload[0];
- JMP_(raiseZh_fast);
+ JMP_(raisezh_fast);
FE_
}
-FN_(raiseZh_fast)
+FN_(raisezh_fast)
{
StgClosure *handler;
StgUpdateFrame *p;
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;
projects / ghc-hetmet.git / commitdiff