idType,
getIdInfo, replaceIdInfo,
getPragmaInfo,
- getIdPrimRep, getInstIdModule,
+ idPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
- getDataConTag,
- getDataConSig, getInstantiatedDataConSig,
- getDataConTyCon,
+ dataConTag,
+ dataConSig, getInstantiatedDataConSig,
+ dataConTyCon, dataConArity,
+ dataConFieldLabels,
+
+ recordSelectorFieldLabel,
-- PREDICATES
isDataCon, isTupleCon,
-- not exported: apply_to_Id, -- please don't use this, generally
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
- getIdArity, getDataConArity, addIdArity,
+ getIdArity, addIdArity,
getIdDemandInfo, addIdDemandInfo,
getIdSpecialisation, addIdSpecialisation,
getIdStrictness, addIdStrictness,
import Ubiq
import IdLoop -- for paranoia checking
import TyLoop -- for paranoia checking
-import NameLoop -- for paranoia checking
import Bag
import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
-import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
-import Name ( Name(..) )
+import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
+ isLocallyDefinedName, isPreludeDefinedName,
+ nameOrigName,
+ RdrName(..), Name
+ )
+import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import Outputable ( isAvarop, isAconop, getLocalName,
- isExported, ExportFlag(..) )
+ isLocallyDefined, isPreludeDefined,
+ getOrigName, getOccName,
+ isExported, ExportFlag(..)
+ )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
-import PprType ( GenType, GenTyVar,
- getTypeString, typeMaybeString, specMaybeTysSuffix )
+import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
+ GenType, GenTyVar
+ )
import PprStyle
import Pretty
import SrcLoc ( mkBuiltinSrcLoc )
-import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons )
-import Type ( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy,
- applyTyCon, isPrimType, instantiateTy,
- GenType, ThetaType(..), TauType(..), Type(..) )
-import TyVar ( GenTyVar, alphaTyVars )
+import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
+import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
+ applyTyCon, isPrimType, instantiateTy,
+ tyVarsOfType, applyTypeEnvToTy, typePrimRep,
+ GenType, ThetaType(..), TauType(..), Type(..)
+ )
+import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
import UniqFM
-import UniqSet ( UniqSet(..) )
-import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
-import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
+import UniqSet -- practically all of it
+import UniqSupply ( getBuiltinUniques )
+import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
+ Unique{-instance Ord3-}
+ )
+import Util ( mapAccumL, nOfThem,
+ panic, panic#, pprPanic, assertPanic
+ )
\end{code}
Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
---------------- Local values
- = LocalId ShortName -- mentioned by the user
+ = LocalId Name -- Local name; mentioned by the user
Bool -- True <=> no free type vars
- | SysLocalId ShortName -- made up by the compiler
+ | SysLocalId Name -- Local name; made up by the compiler
Bool -- as for LocalId
- | SpecPragmaId ShortName -- introduced by the compiler
+ | SpecPragmaId Name -- Local name; introduced by the compiler
(Maybe Id) -- for explicit specid in pragma
Bool -- as for LocalId
---------------- Global values
- | ImportedId FullName -- Id imported from an interface
+ | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface
- | PreludeId FullName -- things < Prelude that compiler "knows" about
+ | PreludeId Name -- Global name (Builtin); Builtin prelude Ids
- | TopLevId FullName -- Top-level in the orig source pgm
+ | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm
-- (not moved there by transformations).
-- a TopLevId's type may contain free type variables, if
---------------- Data constructors
- | DataConId FullName
+ | DataConId Name
ConTag
[StrictnessMark] -- Strict args; length = arity
+ [FieldLabel] -- Field labels for this constructor
[TyVar] [(Class,Type)] [Type] TyCon
-- the type is:
-- forall tyvars . theta_ty =>
-- unitype_1 -> ... -> unitype_n -> tycon tyvars
- | TupleConId Int -- Its arity
+ | TupleConId Name
+ Int -- Its arity
+
+ | RecordSelId FieldLabel
---------------- Things to do with overloading
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
+ (Maybe Module) -- module where instance came from; Nothing => Prelude
-- see below
| ConstMethodId -- A method which depends only on the type of the
Class -- Uniquely identified by:
Type -- (class, type, classop) triple
ClassOp
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
+ Bool -- True => from an instance decl in this mod
+ (Maybe Module) -- module where instance came from; Nothing => Prelude
- | InstId ShortName -- An instance of a dictionary, class operation,
- -- or overloaded value
+ | InstId Name -- An instance of a dictionary, class operation,
+ -- or overloaded value (Local name)
+ Bool -- as for LocalId
| SpecId -- A specialisation of another Id
Id -- Id of which this is a specialisation
%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
-@FullName@). It does {\em not} include those which are moved to the
+@Name@). It does {\em not} include those which are moved to the
top-level through program transformations.
We also guarantee that @TopLevIds@ will {\em stay} at top-level.
isDataCon id = is_data (unsafeGenId2Id id)
where
- is_data (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
- is_data (Id _ _ (TupleConId _) _ _) = True
- is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
- is_data other = False
+ is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
+ is_data (Id _ _ (TupleConId _ _) _ _) = True
+ is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
+ is_data other = False
isTupleCon id = is_tuple (unsafeGenId2Id id)
where
- is_tuple (Id _ _ (TupleConId _) _ _) = True
+ is_tuple (Id _ _ (TupleConId _ _) _ _) = True
is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
is_tuple other = False
toplevelishId (Id _ _ details _ _)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (ImportedId _) = True
- chk (PreludeId _) = True
- chk (TopLevId _) = True -- NB: see notes
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _ _) = True
- chk (ConstMethodId _ _ _ _ _) = True
- chk (SpecId unspec _ _) = toplevelishId unspec
- -- depends what the unspecialised thing is
- chk (WorkerId unwrkr) = toplevelishId unwrkr
- chk (InstId _) = False -- these are local
- chk (LocalId _ _) = False
- chk (SysLocalId _ _) = False
- chk (SpecPragmaId _ _ _) = False
+ chk (DataConId _ _ _ _ _ _ _ _) = True
+ chk (TupleConId _ _) = True
+ chk (RecordSelId _) = True
+ chk (ImportedId _) = True
+ chk (PreludeId _) = True
+ chk (TopLevId _) = True -- NB: see notes
+ chk (SuperDictSelId _ _) = True
+ chk (MethodSelId _ _) = True
+ chk (DefaultMethodId _ _ _) = True
+ chk (DictFunId _ _ _ _) = True
+ chk (ConstMethodId _ _ _ _ _) = True
+ chk (SpecId unspec _ _) = toplevelishId unspec
+ -- depends what the unspecialised thing is
+ chk (WorkerId unwrkr) = toplevelishId unwrkr
+ chk (InstId _ _) = False -- these are local
+ chk (LocalId _ _) = False
+ chk (SysLocalId _ _) = False
+ chk (SpecPragmaId _ _ _) = False
idHasNoFreeTyVars (Id _ _ details _ info)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
+ chk (DataConId _ _ _ _ _ _ _ _) = True
+ chk (TupleConId _ _) = True
+ chk (RecordSelId _) = True
chk (ImportedId _) = True
chk (PreludeId _) = True
chk (TopLevId _) = True
chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
+ chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
- chk (InstId _) = False -- these are local
+ chk (InstId _ no_free_tvs) = no_free_tvs
chk (SpecId _ _ no_free_tvs) = no_free_tvs
chk (LocalId _ no_free_tvs) = no_free_tvs
chk (SysLocalId _ no_free_tvs) = no_free_tvs
isImportedId (Id _ _ (ImportedId _) _ _) = True
isImportedId other = False
-isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
- -- LATER: bottomIsGuaranteed (getInfo info)
+isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
isSysLocalId other = False
in
-- local vars first:
if v `elementOfUniqSet` in_scopes then
- pprUnique (getItsUnique v)
+ pprUnique (idUnique v)
-- ubiquitous Ids with special syntax:
else if v == nilDataCon then
ppPStr SLIT("_NIL_")
else if isTupleCon v then
- ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
+ ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
-- ones to think about:
else
-- these ones' exportedness checked later...
TopLevId _ -> pp_full_name
- DataConId _ _ _ _ _ _ _ -> pp_full_name
+ DataConId _ _ _ _ _ _ _ _ -> pp_full_name
+
+ RecordSelId lbl -> ppr sty lbl
-- class-ish things: class already recorded as "mentioned"
SuperDictSelId c sc
else
ppPStr n_str
in
- if fromPreludeCore v then
+ if isPreludeDefined v then
pp_n
else
ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-- TyVar(Templates) in the i/face; only a problem
-- if -fshow-pragma-name-errs; but we can do without the pain.
-- A HACK in any case (WDP 94/05/02)
- = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun
- --)
+ = naughty_DictFunId dfun
unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
- = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun -- similar deal...
- --)
+ = naughty_DictFunId dfun -- similar deal...
unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
\begin{code}
externallyVisibleId :: Id -> Bool
-externallyVisibleId id = panic "Id.externallyVisibleId"
-{-LATER:
-
externallyVisibleId id@(Id _ _ details _ _)
= if isLocallyDefined id then
toplevelishId id && isExported id && not (weird_datacon details)
-- of WeirdLocalType; but we need to know this when asked if
-- "Mumble" is externally visible...
- weird_datacon (DataConId _ _ _ _ _ _ tycon)
+{- LATER: if at all:
+ weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
= maybeToBool (maybePurelyLocalTyCon tycon)
+-}
weird_datacon not_a_datacon_therefore_not_weird = False
- weird_tuplecon (TupleConId arity)
+ weird_tuplecon (TupleConId _ arity)
= arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
weird_tuplecon _ = False
--}
\end{code}
\begin{code}
-{-LATER:
idWantsToBeINLINEd :: Id -> Bool
-idWantsToBeINLINEd id
- = case (getIdUnfolding id) of
- IWantToBeINLINEd _ -> True
- _ -> False
--}
+idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
+idWantsToBeINLINEd _ = False
\end{code}
For @unlocaliseId@: See the brief commentary in
Nothing -> Nothing
Just xx -> Just (Id u ty info (WorkerId xx))
-unlocaliseId mod (Id u ty info (InstId name))
+unlocaliseId mod (Id u ty info (InstId name no_ftvs))
= Just (Id u ty info (TopLevId full_name))
-- type might be wrong, but it hardly matters
-- at this stage (just before printing C) ToDo
former ``should be'' the usual crunch point.
\begin{code}
-{-LATER:
+type TypeEnv = TyVarEnv Type
+
applyTypeEnvToId :: TypeEnv -> Id -> Id
-applyTypeEnvToId type_env id@(Id u ty info details)
+applyTypeEnvToId type_env id@(Id _ ty _ _ _)
| idHasNoFreeTyVars id
= id
| otherwise
= apply_to_Id ( \ ty ->
applyTypeEnvToTy type_env ty
) id
--}
\end{code}
\begin{code}
-{-LATER:
apply_to_Id :: (Type -> Type)
-> Id
-> Id
-apply_to_Id ty_fn (Id u ty info details)
- = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
+apply_to_Id ty_fn (Id u ty details prag info)
+ = let
+ new_ty = ty_fn ty
+ in
+ Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
where
- apply_to_details (InstId inst)
- = let
- new_inst = apply_to_Inst ty_fn inst
- in
- InstId new_inst
-
apply_to_details (SpecId unspec ty_maybes no_ftvs)
= let
new_unspec = apply_to_Id ty_fn unspec
new_maybes = map apply_to_maybe ty_maybes
in
- SpecId new_unspec new_maybes no_ftvs
- -- ToDo: recalc no_ftvs????
+ SpecId new_unspec new_maybes (no_free_tvs ty)
+ -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
where
apply_to_maybe Nothing = Nothing
apply_to_maybe (Just ty) = Just (ty_fn ty)
WorkerId new_unwrkr
apply_to_details other = other
--}
\end{code}
Sadly, I don't think the one using the magic typechecker substitution
case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
(s4, Id u new_ty new_info new_details) }}}
where
- apply_to_details subst _ (InstId inst)
+ apply_to_details subst _ (InstId inst no_ftvs)
= case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId new_inst) }
+ (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
apply_to_details subst new_ty (SpecId unspec ty_maybes _)
= case (applySubstToId subst unspec) of { (s2, new_unspec) ->
\begin{code}
getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
+
getIdNamePieces show_uniqs id
= get (unsafeGenId2Id id)
where
get (Id u _ details _ _)
= case details of
- DataConId n _ _ _ _ _ _ ->
- case (getOrigName n) of { (mod, name) ->
- if fromPrelude mod then [name] else [mod, name] }
+ DataConId n _ _ _ _ _ _ _ ->
+ case (nameOrigName n) of { (mod, name) ->
+ if isPreludeDefinedName n then [name] else [mod, name] }
- TupleConId 0 -> [SLIT("()")]
- TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
+ TupleConId n _ -> [snd (nameOrigName n)]
+
+ RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
ImportedId n -> get_fullname_pieces n
PreludeId n -> get_fullname_pieces n
case (getOrigName c) of { (c_mod, c_name) ->
case (getOrigName sc) of { (sc_mod, sc_name) ->
let
- c_bits = if fromPreludeCore c
+ c_bits = if isPreludeDefined c
then [c_name]
else [c_mod, c_name]
- sc_bits= if fromPreludeCore sc
+ sc_bits= if isPreludeDefined sc
then [sc_name]
else [sc_mod, sc_name]
in
MethodSelId clas op ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
+ if isPreludeDefined clas
+ then [op_name]
+ else [c_mod, c_name, op_name]
} }
DefaultMethodId clas op _ ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas
+ if isPreludeDefined clas
then [SLIT("defm"), op_name]
else [SLIT("defm"), c_mod, c_name, op_name] }}
DictFunId c ty _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
let
- c_bits = if fromPreludeCore c
+ c_bits = if isPreludeDefined c
then [c_name]
else [c_mod, c_name]
in
[SLIT("dfun")] ++ c_bits ++ ty_bits }
-
ConstMethodId c ty o _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
case (getTypeString ty) of { ty_bits ->
case (getClassOpString o) of { o_name ->
- case (if fromPreludeCore c
- then []
- else [c_mod, c_name]) of { c_bits ->
+ case (if isPreludeDefined c
+ then [c_name]
+ else [c_mod, c_name]) of { c_bits ->
[SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
-- if the unspecialised equiv is "top-level",
LocalId n _ -> let local = getLocalName n in
if show_uniqs then [local, showUnique u] else [local]
- InstId n -> [getLocalName n, showUnique u]
+ InstId n _ -> [getLocalName n, showUnique u]
SysLocalId n _ -> [getLocalName n, showUnique u]
SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-get_fullname_pieces :: FullName -> [FAST_STRING]
+get_fullname_pieces :: Name -> [FAST_STRING]
get_fullname_pieces n
- = BIND (getOrigName n) _TO_ (mod, name) ->
- if fromPrelude mod
+ = BIND (nameOrigName n) _TO_ (mod, name) ->
+ if isPreludeDefinedName n
then [name]
else [mod, name]
BEND
\end{code}
\begin{code}
---getIdPrimRep i = primRepFromType (idType i)
+idPrimRep i = typePrimRep (idType i)
\end{code}
\begin{code}
mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
-mkDictFunId u c ity full_ty from_here modname info
- = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
+mkDictFunId u c ity full_ty from_here mod info
+ = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
-mkConstMethodId u c op ity full_ty from_here modname info
- = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
+mkConstMethodId u c op ity full_ty from_here mod info
+ = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
-mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
+mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
{-LATER:
getConstMethodId clas op ty
in
case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
Just xx -> xx
- Nothing -> error (ppShow 80 (ppAboves [
- ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
- ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
+ Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
+ ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
ppr PprDebug sel_id],
ppStr "(This can arise if an interface pragma refers to an instance",
ppStr "but there is no imported interface which *defines* that instance.",
ppStr "The info above, however ugly, should indicate what else you need to import."
- ]))
+ ])
-}
\end{code}
%************************************************************************
\begin{code}
-mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
-mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info
+mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
+mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info
{-LATER:
updateIdType :: Id -> Type -> Id
\end{code}
\begin{code}
-no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy ty)
+type MyTy a b = GenType (GenTyVar a) b
+type MyId a b = GenId (MyTy a b)
+
+no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
-mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> ty -> SrcLoc -> GenId ty
+mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
- = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal str uniq ty loc
- = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
-- mkUserId builds a local or top-level Id, depending on the name given
-mkUserId :: Name -> ty -> PragmaInfo -> GenId ty
-mkUserId (Short uniq short) ty pragma_info
- = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
-mkUserId (ValName uniq full) ty pragma_info
- = Id uniq ty
- (if isLocallyDefined full then TopLevId full else ImportedId full)
- pragma_info noIdInfo
+mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
+mkUserId name ty pragma_info
+ | isLocalName name
+ = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
+ | otherwise
+ = Id (nameUnique name) ty
+ (if isLocallyDefinedName name then TopLevId name else ImportedId name)
+ pragma_info noIdInfo
\end{code}
where
new_ty = specialiseTy ty ty_maybes 0
- -- pprTrace "SameSpecCon:Unique:"
- -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
-
localiseId :: Id -> Id
localiseId id@(Id u ty info details)
= Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
where
- name = getOccurrenceName id
+ name = getOccName id
loc = getSrcLoc id
+-}
--- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
--- ToDo: it does??? WDP
mkIdWithNewUniq :: Id -> Unique -> Id
-mkIdWithNewUniq (Id _ ty info details) uniq
- = Id uniq ty info new_details
--}
+mkIdWithNewUniq (Id _ ty details prag info) uniq
+ = Id uniq ty details prag info
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
\begin{code}
-{-LATER:
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys
- = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
+ = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
(getBuiltinUniques (length tys))
tys
--}
\end{code}
\begin{code}
getIdArity :: Id -> ArityInfo
getIdArity (Id _ _ _ _ id_info) = getInfo id_info
-getDataConArity :: DataCon -> Int
-getDataConArity id@(Id _ _ _ _ id_info)
+dataConArity :: DataCon -> Int
+dataConArity id@(Id _ _ _ _ id_info)
= ASSERT(isDataCon id)
case (arityMaybe (getInfo id_info)) of
- Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
+ Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
Just i -> i
addIdArity :: Id -> Int -> Id
%************************************************************************
\begin{code}
-mkDataCon :: Unique{-DataConKey-}
- -> FullName
- -> [StrictnessMark]
+mkDataCon :: Name
+ -> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType -> [TauType] -> TyCon
--ToDo: -> SpecEnv
-> Id
-- can get the tag and all the pieces of the type from the Type
-mkDataCon k n stricts tvs ctxt args_tys tycon
+mkDataCon n stricts fields tvs ctxt args_tys tycon
= ASSERT(length stricts == length args_tys)
data_con
where
-- NB: data_con self-recursion; should be OK as tags are not
-- looked at until late in the game.
data_con
- = Id k
+ = Id (nameUnique n)
type_of_constructor
- (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
+ (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
NoPragmaInfo
datacon_info
data_con_tag = position_within fIRST_TAG data_con_family
- data_con_family = getTyConDataCons tycon
+ data_con_family = tyConDataCons tycon
position_within :: Int -> [Id] -> Int
type_of_constructor
= mkSigmaTy tvs ctxt
- (mkFunTys args_tys (applyTyCon tycon (map mkTyVarTy tvs)))
+ (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
datacon_info = noIdInfo `addInfo_UF` unfolding
`addInfo` mkArityInfo arity
-- else -- do some business...
let
(tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
in
BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
mkTupleCon :: Arity -> Id
mkTupleCon arity
- = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
+ = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
where
+ n = panic "mkTupleCon: its Name (Id)"
unique = mkTupleDataConUnique arity
ty = mkSigmaTy tyvars []
(mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
tycon = mkTupleTyCon arity
tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
tuplecon_info
= noIdInfo `addInfo_UF` unfolding
-- else -- do some business...
let
(tyvars, dict_vars, vars) = mk_uf_bits arity
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
in
BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
\end{code}
\begin{code}
-getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-getDataConTag (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
-getDataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
-getDataConTag (Id _ _ (SpecId unspec _ _) _ _) = getDataConTag unspec
+dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
+dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
+dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG
+dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
-getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
-getDataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
+dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
+dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
+dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a
-getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
+dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
-getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
+dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
= (tyvars, theta_ty, arg_tys, tycon)
-getDataConSig (Id _ _ (TupleConId arity) _ _)
+dataConSig (Id _ _ (TupleConId _ arity) _ _)
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
+
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
+\end{code}
+
+\begin{code}
+mkRecordSelId field_label selector_ty
+ = Id (nameUnique name)
+ selector_ty
+ (RecordSelId field_label)
+ NoPragmaInfo
+ noIdInfo
+ where
+ name = fieldLabelName field_label
+
+recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
\end{code}
{- LATER
-getDataConTyCon (Id _ _ _ (SpecId unspec tys _))
- = mkSpecTyCon (getDataConTyCon unspec) tys
+dataConTyCon (Id _ _ _ (SpecId unspec tys _))
+ = mkSpecTyCon (dataConTyCon unspec) tys
-getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
+dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
= (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
where
- (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
+ (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
ty_env = tyvars `zip` ty_maybes
spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
spec_theta_ty = if null theta_ty then []
- else panic "getDataConSig:ThetaTy:SpecDataCon"
+ else panic "dataConSig:ThetaTy:SpecDataCon"
spec_tycon = mkSpecTyCon tycon ty_maybes
-}
\end{code}
getInstantiatedDataConSig data_con inst_tys
= ASSERT(isDataCon data_con)
let
- (tvs, theta, arg_tys, tycon) = getDataConSig data_con
+ (tvs, theta, arg_tys, tycon) = dataConSig data_con
inst_env = ASSERT(length tvs == length inst_tys)
tvs `zip` inst_tys
unspecialised counterpart.
\begin{code}
-{-LATER:
cmpId_withSpecDataCon :: Id -> Id -> TAG_
cmpId_withSpecDataCon id1 id2
cmp_ids = cmpId id1 id2
eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
-cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
- = cmpUniTypeMaybeList mtys1 mtys2
-
-cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
- = LT_
+cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
+ = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
-cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
- = GT_
-
-cmpEqDataCon unspec1 unspec2
- = EQ_
--}
+cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
+cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
+cmpEqDataCon _ _ = EQ_
\end{code}
%************************************************************************
instance Outputable ty => Outputable (GenId ty) where
ppr sty id = pprId sty id
+-- and a SPECIALIZEd one:
+instance Outputable {-Id, i.e.:-}(GenId Type) where
+ ppr sty id = pprId sty id
+
showId :: PprStyle -> Id -> String
showId sty id = ppShow 80 (pprId sty id)
-}
\end{code}
-Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
-PreludeCore''? True if the outermost TyCon is fromPreludeCore.
-\begin{code}
-is_prelude_core_ty :: Type -> Bool
-
-is_prelude_core_ty inst_ty
- = panic "Id.is_prelude_core_ty"
-{- LATER
- = case maybeDataTyCon inst_ty of
- Just (tycon,_,_) -> fromPreludeCore tycon
- Nothing -> panic "Id: is_prelude_core_ty"
--}
-\end{code}
-
Default printing code (not used for interfaces):
\begin{code}
pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
= let
pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
- for_code = panic "pprId: for code"
- {- = let
+ for_code
+ = let
pieces_to_print -- maybe use Unique only
= if isSysLocalId id then tail pieces else pieces
in
ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
- -}
in
case other_sty of
PprForC -> for_code
PprForAsm _ _ -> for_code
- PprInterface -> ppPStr occur_name
- PprForUser -> ppPStr occur_name
+ PprInterface -> ppr other_sty occur_name
+ PprForUser -> ppr other_sty occur_name
PprUnfolding -> qualified_name pieces
PprDebug -> qualified_name pieces
PprShowAll -> ppBesides [qualified_name pieces,
(\x->x) nullIdEnv (getIdInfo id),
ppPStr SLIT("-}") ])]
where
- occur_name = getOccurrenceName id _APPEND_
- ( _PK_ (if not (isSysLocalId id)
- then ""
- else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
+ occur_name = getOccName id `appendRdr`
+ (if not (isSysLocalId id)
+ then SLIT("")
+ else SLIT(".") _APPEND_ (showUnique (idUnique id)))
qualified_name pieces
= ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
- pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
+ pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
+ pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (InstId _) _ _) = ppNil
- pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
+ pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
+ pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
-- print PprDebug Ids with # afterwards if they are of primitive type.
pp_ubxd pretty = pretty
\end{code}
\begin{code}
+idUnique (Id u _ _ _ _) = u
+
+instance Uniquable (GenId ty) where
+ uniqueOf = idUnique
+
instance NamedThing (GenId ty) where
- getExportFlag (Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
- get (TupleConId _) = NotExported
- get (ImportedId n) = getExportFlag n
- get (PreludeId n) = getExportFlag n
- get (TopLevId n) = getExportFlag n
- get (SuperDictSelId c _) = getExportFlag c
- get (MethodSelId c _) = getExportFlag c
- get (DefaultMethodId c _ _) = getExportFlag c
- get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
- get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
- get (SpecId unspec _ _) = getExportFlag unspec
- get (WorkerId unwrkr) = getExportFlag unwrkr
- get (InstId _) = NotExported
- get (LocalId _ _) = NotExported
- get (SysLocalId _ _) = NotExported
- get (SpecPragmaId _ _ _) = NotExported
-
- isLocallyDefined this_id@(Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
- get (TupleConId _) = False
- get (ImportedId _) = False
- get (PreludeId _) = False
- get (TopLevId n) = isLocallyDefined n
- get (SuperDictSelId c _) = isLocallyDefined c
- get (MethodSelId c _) = isLocallyDefined c
- get (DefaultMethodId c _ _) = isLocallyDefined c
- get (DictFunId c tyc from_here _) = from_here
- -- For DictFunId and ConstMethodId things, you really have to
- -- know whether it came from an imported instance or one
- -- really here; no matter where the tycon and class came from.
-
- get (ConstMethodId c tyc _ from_here _) = from_here
- get (SpecId unspec _ _) = isLocallyDefined unspec
- get (WorkerId unwrkr) = isLocallyDefined unwrkr
- get (InstId _) = True
- get (LocalId _ _) = True
- get (SysLocalId _ _) = True
- get (SpecPragmaId _ _ _) = True
-
- getOrigName this_id@(Id u _ details _ _)
+ getName this_id@(Id u _ details _ _)
= get details
where
- get (DataConId n _ _ _ _ _ _) = getOrigName n
- get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
- get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
- get (ImportedId n) = getOrigName n
- get (PreludeId n) = getOrigName n
- get (TopLevId n) = getOrigName n
+ get (LocalId n _) = n
+ get (SysLocalId n _) = n
+ get (SpecPragmaId n _ _)= n
+ get (ImportedId n) = n
+ get (PreludeId n) = n
+ get (TopLevId n) = n
+ get (InstId n _) = n
+ get (DataConId n _ _ _ _ _ _ _) = n
+ get (TupleConId n _) = n
+ get (RecordSelId l) = getName l
+-- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
+{- LATER:
get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
(mod, _) -> (mod, getClassOpString op)
-{- LATER:
get (SpecId unspec ty_maybes _)
= BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
else SLIT(".wrk"))
)
BEND
--}
-
- get (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
- getLocalName n)
- get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
- getLocalName n)
get other_details
-- the remaining internally-generated flavours of
BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
(_NIL_, _CONCAT_ (piece1 : dotted_pieces))
BEND BEND
-
- getOccurrenceName this_id@(Id _ _ details _ _)
- = get details
- where
- get (DataConId n _ _ _ _ _ _) = getOccurrenceName n
- get (TupleConId 0) = SLIT("()")
- get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
- get (ImportedId n) = getOccurrenceName n
- get (PreludeId n) = getOccurrenceName n
- get (TopLevId n) = getOccurrenceName n
- get (MethodSelId _ op) = getClassOpString op
- get _ = snd (getOrigName this_id)
-
- getInformingModules id = panic "getInformingModule:Id"
-
- getSrcLoc (Id _ _ details _ id_info)
- = get details
- where
- get (DataConId n _ _ _ _ _ _) = getSrcLoc n
- get (TupleConId _) = mkBuiltinSrcLoc
- get (ImportedId n) = getSrcLoc n
- get (PreludeId n) = getSrcLoc n
- get (TopLevId n) = getSrcLoc n
- get (SuperDictSelId c _)= getSrcLoc c
- get (MethodSelId c _) = getSrcLoc c
- get (SpecId unspec _ _) = getSrcLoc unspec
- get (WorkerId unwrkr) = getSrcLoc unwrkr
- get (InstId n) = getSrcLoc n
- get (LocalId n _) = getSrcLoc n
- get (SysLocalId n _) = getSrcLoc n
- get (SpecPragmaId n _ _)= getSrcLoc n
- -- well, try the IdInfo
- get something_else = getSrcLocIdInfo id_info
-
- getItsUnique (Id u _ _ _ _) = u
-
- fromPreludeCore (Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
- get (TupleConId _) = True
- get (ImportedId n) = fromPreludeCore n
- get (PreludeId n) = fromPreludeCore n
- get (TopLevId n) = fromPreludeCore n
- get (SuperDictSelId c _) = fromPreludeCore c
- get (MethodSelId c _) = fromPreludeCore c
- get (DefaultMethodId c _ _) = fromPreludeCore c
- get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
- get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
- get (SpecId unspec _ _) = fromPreludeCore unspec
- get (WorkerId unwrkr) = fromPreludeCore unwrkr
- get (InstId _) = False
- get (LocalId _ _) = False
- get (SysLocalId _ _) = False
- get (SpecPragmaId _ _ _) = False
+-}
\end{code}
-Reason for @getItsUnique@: The code generator doesn't carry a
-@UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
-given to it.
+Note: The code generator doesn't carry a @UniqueSupply@, so it uses
+the @Uniques@ out of local @Ids@ given to it.
%************************************************************************
%* *
mkIdEnv = listToUFM
nullIdEnv = emptyUFM
rngIdEnv = eltsUFM
-unitIdEnv = singletonUFM
+unitIdEnv = unitUFM
growIdEnvList env pairs = plusUFM env (listToUFM pairs)
isNullIdEnv env = sizeUFM env == 0
\begin{code}
type GenIdSet ty = UniqSet (GenId ty)
type IdSet = UniqSet (GenId Type)
+
+emptyIdSet :: GenIdSet ty
+intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
+unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
+unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
+idSetToList :: GenIdSet ty -> [GenId ty]
+unitIdSet :: GenId ty -> GenIdSet ty
+addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
+elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
+minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
+isEmptyIdSet :: GenIdSet ty -> Bool
+mkIdSet :: [GenId ty] -> GenIdSet ty
+
+emptyIdSet = emptyUniqSet
+unitIdSet = unitUniqSet
+addOneToIdSet = addOneToUniqSet
+intersectIdSets = intersectUniqSets
+unionIdSets = unionUniqSets
+unionManyIdSets = unionManyUniqSets
+idSetToList = uniqSetToList
+elementOfIdSet = elementOfUniqSet
+minusIdSet = minusUniqSet
+isEmptyIdSet = isEmptyUniqSet
+mkIdSet = mkUniqSet
\end{code}
projects / ghc-hetmet.git / blobdiff