Commit ae45ff0e authored by partain's avatar partain

[project @ 1996-06-11 13:18:54 by partain]

SLPJ changes to 960611
parent e7498a3e
......@@ -99,7 +99,7 @@ you will screw up the layout where they are used in case expressions!
#endif {- ! __GLASGOW_HASKELL__ -}
#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200
#if __GLASGOW_HASKELL__ >= 23
#define USE_FAST_STRINGS 1
#define FAST_STRING _PackedString
#define SLIT(x) (_packCString (A# x#))
......
......@@ -218,8 +218,6 @@ data CStmtMacro
| UPD_BH_SINGLE_ENTRY
| PUSH_STD_UPD_FRAME
| POP_STD_UPD_FRAME
| SET_ARITY
| CHK_ARITY
| SET_TAG
| GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL
......@@ -502,34 +500,34 @@ We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
\begin{code}
instance Eq MagicId where
reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2
tagOf_MagicId BaseReg = (ILIT(0) :: FAST_INT)
tagOf_MagicId StkOReg = ILIT(1)
tagOf_MagicId TagReg = ILIT(2)
tagOf_MagicId RetReg = ILIT(3)
tagOf_MagicId SpA = ILIT(4)
tagOf_MagicId SuA = ILIT(5)
tagOf_MagicId SpB = ILIT(6)
tagOf_MagicId SuB = ILIT(7)
tagOf_MagicId Hp = ILIT(8)
tagOf_MagicId HpLim = ILIT(9)
tagOf_MagicId LivenessReg = ILIT(10)
tagOf_MagicId StdUpdRetVecReg = ILIT(12)
tagOf_MagicId StkStubReg = ILIT(13)
tagOf_MagicId CurCostCentre = ILIT(14)
tagOf_MagicId VoidReg = ILIT(15)
tagOf_MagicId (VanillaReg _ i) = ILIT(15) _ADD_ i
tagOf_MagicId (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i
where
maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
tagOf_MagicId (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i
where
maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
maxf = case mAX_Float_REG of { IBOX(x) -> x }
reg1 == reg2 = tag reg1 _EQ_ tag reg2
where
tag BaseReg = (ILIT(0) :: FAST_INT)
tag StkOReg = ILIT(1)
tag TagReg = ILIT(2)
tag RetReg = ILIT(3)
tag SpA = ILIT(4)
tag SuA = ILIT(5)
tag SpB = ILIT(6)
tag SuB = ILIT(7)
tag Hp = ILIT(8)
tag HpLim = ILIT(9)
tag LivenessReg = ILIT(10)
tag StdUpdRetVecReg = ILIT(12)
tag StkStubReg = ILIT(13)
tag CurCostCentre = ILIT(14)
tag VoidReg = ILIT(15)
tag (VanillaReg _ i) = ILIT(15) _ADD_ i
tag (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i
where
maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
tag (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i
where
maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
maxf = case mAX_Float_REG of { IBOX(x) -> x }
\end{code}
Returns True for any register that {\em potentially} dies across
......
......@@ -363,8 +363,6 @@ stmtMacroCosts macro modes =
UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -}
SET_ARITY -> nullCosts {- StgMacros.lh -}
CHK_ARITY -> nullCosts {- StgMacros.lh -}
SET_TAG -> nullCosts {- COptRegs.lh -}
GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
......
......@@ -17,7 +17,7 @@ module Id {- (
mkSpecId, mkSameSpecCon,
selectIdInfoForSpecId,
mkTemplateLocals,
mkImported, mkPreludeId,
mkImported,
mkDataCon, mkTupleCon,
mkIdWithNewUniq,
mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
......@@ -105,11 +105,11 @@ import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
isLocallyDefinedName,
mkTupleDataConName, mkCompoundName, mkCompoundName2,
isLexSym, isLexSpecialSym, getLocalName,
isLocallyDefined, isPreludeDefined, changeUnique,
getOccName, moduleNamePair, origName, nameOf,
isLexSym, isLexSpecialSym,
isLocallyDefined, changeUnique,
getOccName, origName, moduleOf,
isExported, ExportFlag(..),
RdrName(..), Name
)
......@@ -183,8 +183,6 @@ data IdDetails
| ImportedId -- Global name (Imported or Implicit); Id imported from an interface
| PreludeId -- Global name (Builtin); Builtin prelude Ids
| TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
-- (not moved there by transformations).
......@@ -237,7 +235,7 @@ data IdDetails
-- The "a" is irrelevant. As it is too painful to
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
(Maybe Module) -- module where instance came from; Nothing => Prelude
Module -- module where instance came from
-- see below
| ConstMethodId -- A method which depends only on the type of the
......@@ -245,7 +243,7 @@ data IdDetails
Class -- Uniquely identified by:
Type -- (class, type, classop) triple
ClassOp
(Maybe Module) -- module where instance came from; Nothing => Prelude
Module -- module where instance came from
| InstId -- An instance of a dictionary, class operation,
-- or overloaded value (Local name)
......@@ -357,9 +355,6 @@ the infinite family of tuples.
{\em Everything} we want to know about them must be stored here (or in
their @IdInfo@).
%----------------------------------------------------------------------
\item[@PreludeId@:] ToDo
%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
......@@ -499,7 +494,6 @@ toplevelishId (Id _ _ _ details _ _)
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
chk PreludeId = True
chk TopLevId = True -- NB: see notes
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
......@@ -521,7 +515,6 @@ idHasNoFreeTyVars (Id _ _ _ details _ info)
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
chk PreludeId = True
chk TopLevId = True
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
......@@ -608,7 +601,6 @@ pprIdInUnfolding in_scopes v
case v_details of
-- these ones must have been exported by their original module
ImportedId -> pp_full_name
PreludeId -> pp_full_name
-- these ones' exportedness checked later...
TopLevId -> pp_full_name
......@@ -653,7 +645,7 @@ pprIdInUnfolding in_scopes v
pp_full_name
= let
(m_str, n_str) = moduleNamePair v
(OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
pp_n =
if isLexSym n_str && not (isLexSpecialSym n_str) then
......@@ -877,7 +869,7 @@ unlocaliseId mod (Id u name ty info (InstId no_ftvs))
-- type might be wrong, but it hardly matters
-- at this stage (just before printing C) ToDo
where
name = getLocalName name
name = nameOf (origName "Id.unlocaliseId" name)
full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
unlocaliseId mod other_id = Nothing
......@@ -1038,42 +1030,41 @@ getInstIdModule other = panic "Id:getInstIdModule"
\begin{code}
mkSuperDictSelId u c sc ty info
= Id u n ty (SuperDictSelId c sc) NoPragmaInfo info
where
cname = getName c -- we get other info out of here
n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
= mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
mkMethodSelId u rec_c op ty info
= Id u n ty (MethodSelId rec_c op) NoPragmaInfo info
where
cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
= mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
mkDefaultMethodId u rec_c op gen ty info
= Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info
= mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
mk_classy_id details str op_str u rec_c ty info
= Id u n ty details NoPragmaInfo info
where
cname = getName rec_c -- we get other info out of here
cname_orig = origName "mk_classy_id" cname
cmod = moduleOf cname_orig
n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
mkDictFunId u c ity full_ty from_here locn mod info
= Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
where
n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn
n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : map Right (getTypeString ity)) from_here locn
mkConstMethodId u c op ity full_ty from_here locn mod info
= Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
where
n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn
n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : map Right (getTypeString ity)) from_here locn
mkWorkerId u unwrkr ty info
= Id u n ty (WorkerId unwrkr) NoPragmaInfo info
where
unwrkr_name = getName unwrkr
unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name
umod = moduleOf unwrkr_orig
n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name
n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
......@@ -1104,7 +1095,6 @@ getConstMethodId clas op ty
\begin{code}
mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info
{-LATER:
updateIdType :: Id -> Type -> Id
......@@ -1642,23 +1632,6 @@ instance Outputable {-Id, i.e.:-}(GenId Type) where
showId :: PprStyle -> Id -> String
showId sty id = ppShow 80 (pprId sty id)
-- [used below]
-- for DictFuns (instances) and const methods (instance code bits we
-- can call directly): exported (a) if *either* the class or
-- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
-- class and tycon are from PreludeCore [non-std, but convenient]
-- *and* the thing was defined in this module.
instance_export_flag :: Class -> Type -> Bool -> ExportFlag
instance_export_flag clas inst_ty from_here
= panic "Id:instance_export_flag"
{-LATER
= if instanceIsExported clas inst_ty from_here
then ExportAll
else NotExported
-}
\end{code}
Default printing code (not used for interfaces):
......@@ -1677,53 +1650,6 @@ instance Uniquable (GenId ty) where
instance NamedThing (GenId ty) where
getName this_id@(Id u n _ details _ _) = n
{- OLD:
= get details
where
get (LocalId _) = n
get (SysLocalId _) = n
get (SpecPragmaId _ _) = n
get ImportedId = n
get PreludeId = n
get TopLevId = n
get (InstId n _) = n
get (DataConId _ _ _ _ _ _ _) = n
get (TupleConId _) = n
get (RecordSelId l) = getName l
get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
-}
{- LATER:
get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
mod -> (mod, classOpString op)
get (SpecId unspec ty_maybes _)
= case moduleNamePair unspec of { (mod, unspec_nm) ->
case specMaybeTysSuffix ty_maybes of { tys_suffix ->
(mod,
unspec_nm _APPEND_
(if not (toplevelishId unspec)
then showUnique u
else tys_suffix)
) }}
get (WorkerId unwrkr)
= case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
(mod,
unwrkr_nm _APPEND_
(if not (toplevelishId unwrkr)
then showUnique u
else SLIT(".wrk"))
) }
get other_details
-- the remaining internally-generated flavours of
-- Ids really do not have meaningful "original name" stuff,
-- but we need to make up something (usually for debugging output)
= case (getIdNamePieces True this_id) of { (piece1:pieces) ->
case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
(_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
-}
\end{code}
Note: The code generator doesn't carry a @UniqueSupply@, so it uses
......
......@@ -69,7 +69,7 @@ module IdInfo (
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
-- we break those loops by using IdLoop and
-- *not* importing much of anything else,
-- except from the very general "utils".
......@@ -77,7 +77,6 @@ IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList )
import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
......
......@@ -18,6 +18,7 @@ import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
import IdInfo ( IdInfo )
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( Outputable(..) )
import PprEnv ( NmbrEnv )
import PprStyle ( PprStyle )
......@@ -31,6 +32,7 @@ import Usage ( GenUsage )
import Util ( Ord3(..) )
import WwLib ( mAX_WORKER_ARGS )
occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
externallyVisibleId :: Id -> Bool
isDataCon :: GenId ty -> Bool
isWorkerId :: GenId ty -> Bool
......
......@@ -13,10 +13,10 @@ IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( mkPreludeId, mkTemplateLocals )
import Id ( mkImported, mkTemplateLocals )
import IdInfo -- quite a few things
import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import Name ( mkPrimitiveName, OrigName(..) )
import PrelMods ( gHC_BUILTINS )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn ( RnName(..) )
......@@ -35,33 +35,33 @@ primOpNameInfo op = (primOp_str op, WiredInId (primOpId op))
primOpId op
= case (primOpInfo op) of
Dyadic str ty ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
Monadic str ty ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
Compare str ty ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
Coercing str ty1 ty2 ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
mk_prim_Id op str [] [ty1] (mkFunTys [ty1] ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mk_prim_Id op pRELUDE_BUILTIN str
mk_prim_Id op str
tyvars
arg_tys
(mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
(length arg_tys) -- arity
AlgResult str tyvars arg_tys tycon res_tys ->
mk_prim_Id op pRELUDE_BUILTIN str
mk_prim_Id op str
tyvars
arg_tys
(mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
(length arg_tys) -- arity
where
mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
= mkPreludeId (mkBuiltinName key mod name) ty
mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
= mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
(noIdInfo `addInfo` (mkArityInfo arity)
`addInfo_UF` (mkUnfolding EssentialUnfolding
(mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
......
......@@ -9,7 +9,12 @@
module Name (
Module(..),
OrigName(..), -- glorified pair
qualToOrigName, -- a Qual to an OrigName
RdrName(..),
preludeQual,
moduleNamePair,
isUnqual,
isQual,
isRdrLexCon, isRdrLexConOrSpecial,
......@@ -20,9 +25,10 @@ module Name (
Name,
Provenance,
mkLocalName, isLocalName,
mkTopLevName, mkImportedName,
mkTopLevName, mkImportedName, oddlyImportedName,
mkImplicitName, isImplicitName,
mkBuiltinName, mkCompoundName, mkCompoundName2,
mkPrimitiveName, mkWiredInName,
mkCompoundName, mkCompoundName2,
mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
mkTupNameStr,
......@@ -33,19 +39,18 @@ module Name (
nameUnique, changeUnique,
nameOccName,
nameOrigName,
-- nameOrigName, : not exported
nameExportFlag,
nameSrcLoc,
nameImpLocs,
nameImportFlag,
isLocallyDefinedName,
isPreludeDefinedName,
isLocallyDefinedName, isWiredInName,
origName, moduleOf, nameOf, moduleNamePair,
origName, moduleOf, nameOf,
getOccName, getExportFlag,
getSrcLoc, getImpLocs,
isLocallyDefined, isPreludeDefined,
getLocalName, ltLexical,
isLocallyDefined,
getLocalName,
isSymLexeme, pprSym, pprNonSym,
isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
......@@ -54,10 +59,11 @@ module Name (
IMP_Ubiq()
import CmdLineOpts ( maybe_CompilingPrelude )
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..), codeStyle )
import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
import PrelMods ( pRELUDE )
import Pretty
import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
......@@ -79,10 +85,20 @@ ord = fromEnum :: Char -> Int
\begin{code}
type Module = FAST_STRING
data OrigName = OrigName Module FAST_STRING
qualToOrigName (Qual m n) = OrigName m n
data RdrName
= Unqual FAST_STRING
| Qual Module FAST_STRING
preludeQual n = Qual pRELUDE n
moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this
-- constitutes an original name or
-- an occurrence name, or anything else
isUnqual (Unqual _) = True
isUnqual (Qual _ _) = False
......@@ -96,13 +112,16 @@ isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
Qual m (n _APPEND_ str)
appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
cmpRdr (Unqual n1) (Qual m2 n2) = LT_
cmpRdr (Qual m1 n1) (Unqual n2) = GT_
cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
cmpRdr (Unqual n1) (Qual m2 n2) = LT_
cmpRdr (Qual m1 n1) (Unqual n2) = GT_
cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2
-- always compare module-names *second*
cmpOrig (OrigName m1 n1) (OrigName m2 n2)
= _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second*
instance Eq RdrName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
......@@ -119,8 +138,14 @@ instance Ord3 RdrName where
instance NamedThing RdrName where
-- We're sorta faking it here
getName rdr_name
= Global u rdr_name prov ex [rdr_name]
getName (Unqual n)
= Local u n True locn
where
u = panic "NamedThing.RdrName:Unique1"
locn = panic "NamedThing.RdrName:locn"
getName rdr_name@(Qual m n)
= Global u m n prov ex [rdr_name]
where
u = panic "NamedThing.RdrName:Unique"
prov = panic "NamedThing.RdrName:Provenance"
......@@ -139,6 +164,26 @@ pp_name sty n | codeStyle sty = identToC n
| otherwise = ppPStr n
showRdr sty rdr = ppShow 100 (ppr sty rdr)
-------------------------
instance Eq OrigName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord OrigName where
a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
instance Ord3 OrigName where
cmp = cmpOrig
instance NamedThing OrigName where -- faking it
getName (OrigName m n) = getName (Qual m n)
instance Outputable OrigName where -- ditto
ppr sty (OrigName m n) = ppr sty (Qual m n)
\end{code}
%************************************************************************
......@@ -156,7 +201,8 @@ data Name
SrcLoc
| Global Unique
RdrName -- original name; Unqual => prelude
Module -- original name
FAST_STRING
Provenance -- where it came from
ExportFlag -- is it exported?
[RdrName] -- ordered occurrence names (usually just one);
......@@ -170,57 +216,71 @@ data Provenance
[SrcLoc] -- any import source location(s)
| Implicit
| Builtin
| Primitive -- really and truly primitive thing (not
-- definable in Haskell)
| WiredIn Bool -- something defined in Haskell; True <=>
-- definition is in the module in question;
-- this probably comes from the -fcompiling-prelude=...
-- flag.
\end{code}
\begin{code}
mkLocalName = Local
mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
mkTopLevName u (OrigName m n) locn exp occs = Global u m n (LocalDef locn) exp occs
mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m n (Imported imp locn imp_locs) exp occs
mkImplicitName :: Unique -> RdrName -> Name
mkImplicitName u o = Global u o Implicit NotExported []
mkImplicitName :: Unique -> OrigName -> Name
mkImplicitName u (OrigName m n) = Global u m n Implicit NotExported []
mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
mkBuiltinName u m n
= Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported []
mkPrimitiveName :: Unique -> OrigName -> Name
mkPrimitiveName u (OrigName m n) = Global u m n Primitive NotExported []
mkWiredInName :: Unique -> OrigName -> Name
mkWiredInName u (OrigName m n)
= Global u m n (WiredIn from_here) (if from_here then ExportAll else NotExported) []
where
from_here
= case maybe_CompilingPrelude of
Nothing -> False
Just mod -> mod == _UNPK_ m
mkCompoundName :: Unique
-> Module
-> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
-> [RdrName] -- "dot" these names together
-> [Either OrigName FAST_STRING] -- "dot" these names together
-> Name -- from which we get provenance, etc....
-> Name -- result!
mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
mkCompoundName u str ns (Global _ _ prov exp _)
= Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
mkCompoundName u m str ns (Global _ _ _ prov exp _)
= Global u m (_CONCAT_ (glue ns [str])) prov exp []
glue [] acc = reverse acc
glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
glue [] acc = reverse acc
glue (Left (OrigName m n):ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
glue (Right n :ns) acc = glue ns (_CONS_ '.' n : acc)
-- this ugly one is used for instance-y things
mkCompoundName2 :: Unique
-> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
-> [RdrName] -- "dot" these names together
-> [FAST_STRING] -- type-name strings
-> Bool -- True <=> defined in this module
-> SrcLoc