-import Pretty -- for pretty-printing
-import SrcLoc
-import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE
-import PlainCore
-import PrelFuns ( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
-import UniqFM
-import UniqSet
-import Unique
-import Util
-#ifdef DPH
-IMPORT_Trace
-import PodizeCore ( podizeTemplateExpr )
-import PodInfoTree ( infoTypeNumToMask )
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
-follow.
-
-Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
-@UniType@, and an @IdInfo@ (non-essential info about it, e.g.,
-strictness). The essential info about different kinds of @Ids@ is
-in its @IdDetails@.
-
-ToDo: possibly cache other stuff in the single-constructor @Id@ type.
-
-\begin{code}
-data Id = Id Unique -- key for fast comparison
- UniType -- Id's type; used all the time;
- IdInfo -- non-essential info about this Id;
- IdDetails -- stuff about individual kinds of Ids.
-
-data IdDetails
-
- ---------------- Local values
-
- = LocalId ShortName -- mentioned by the user
- Bool -- True <=> no free type vars
-
- | SysLocalId ShortName -- made up by the compiler
- Bool -- as for LocalId
-
- | SpecPragmaId ShortName -- introduced by the compiler
- (Maybe SpecInfo)-- for explicit specid in pragma
- Bool -- as for LocalId
-
- ---------------- Global values
-
- | ImportedId FullName -- Id imported from an interface
-
- | PreludeId FullName -- things < Prelude that compiler "knows" about
-
- | TopLevId FullName -- Top-level in the orig source pgm
- -- (not moved there by transformations).
-
- -- a TopLevId's type may contain free type variables, if
- -- the monomorphism restriction applies.
-
- ---------------- Data constructors
-
- | DataConId FullName
- ConTag
- -- cached pieces of the type:
- [TyVarTemplate] [(Class,UniType)] [UniType] TyCon
- -- the type is:
- -- forall tyvars . theta_ty =>
- -- unitype_1 -> ... -> unitype_n -> tycon tyvars
- --
- -- "type ThetaType = [(Class, UniType)]"
-
- -- The [TyVarTemplate] is in the same order as the args of the
- -- TyCon for the constructor
-
- | TupleConId Int -- Its arity
-
-#ifdef DPH
- | ProcessorCon Int -- Its arity
-#endif {- Data Parallel Haskell -}
-
- ---------------- Things to do with overloading
-
- | SuperDictSelId -- Selector for superclass dictionary
- Class -- The class (input dict)
- Class -- The superclass (result dict)
-
- | ClassOpId Class -- An overloaded class operation, with
- -- a fully polymorphic type. Its code
- -- just selects a method from the
- -- dictionary. The class.
- ClassOp -- The operation
-
- -- NB: The IdInfo for a ClassOpId has all the info about its
- -- related "constant method Ids", which are just
- -- specialisations of this general one.
-
- | DefaultMethodId -- Default method for a particular class op
- Class -- same class, <blah-blah> info as ClassOpId
- ClassOp -- (surprise, surprise)
- Bool -- True <=> I *know* this default method Id
- -- is a generated one that just says
- -- `error "No default method for <op>"'.
-\end{code}
-
-DictFunIds are generated from instance decls.
-\begin{verbatim}
- class Foo a where
- op :: a -> a -> Bool
-
- instance Foo a => Foo [a] where
- op = ...
-\end{verbatim}
-generates the dict fun id decl
-\begin{verbatim}
- dfun.Foo.[*] = \d -> ...
-\end{verbatim}
-The dfun id is uniquely named by the (class, type) pair. Notice, it
-isn't a (class,tycon) pair any more, because we may get manually or
-automatically generated specialisations of the instance decl:
-\begin{verbatim}
- instance Foo [Int] where
- op = ...
-\end{verbatim}
-generates
-\begin{verbatim}
- dfun.Foo.[Int] = ...
-\end{verbatim}
-The type variables in the name are irrelevant; we print them as stars.
-
-\begin{code}
- | DictFunId Class -- A DictFun is uniquely identified
- UniType -- by its class and type; this type has free type vars,
- -- whose identity is irrelevant. Eg Class = Eq
- -- Type = Tree a
- -- The "a" is irrelevant. As it is too painful to
- -- 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
-\end{code}
-
-Constant method ids are generated from instance decls where
-there is no context; that is, no dictionaries are needed to
-construct the method. Example
-\begin{verbatim}
- instance Foo Int where
- op = ...
-\end{verbatim}
-Then we get a constant method
-\begin{verbatim}
- Foo.op.Int = ...
-\end{verbatim}
-
-It is possible, albeit unusual, to have a constant method
-for an instance decl which has type vars:
-\begin{verbatim}
- instance Foo [a] where
- op [] ys = True
- op (x:xs) ys = False
-\end{verbatim}
-We get the constant method
-\begin{verbatim}
- Foo.op.[*] = ...
-\end{verbatim}
-So a constant method is identified by a class/op/type triple.
-The type variables in the type are irrelevant.
-
-\begin{code}
- | ConstMethodId -- A method which depends only on the type of the
- -- instance, and not on any further dictionaries etc.
- Class -- Uniquely identified by:
- UniType -- (class, type, classop) triple
- ClassOp
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
-
- | InstId Inst -- An instance of a dictionary, class operation,
- -- or overloaded value
-
- | SpecId -- A specialisation of another Id
- Id -- Id of which this is a specialisation
- [Maybe UniType] -- Types at which it is specialised;
- -- A "Nothing" says this type ain't relevant.
- Bool -- True <=> no free type vars; it's not enough
- -- to know about the unspec version, because
- -- we may specialise to a type w/ free tyvars
- -- (i.e., in one of the "Maybe UniType" dudes).
-
- | WorkerId -- A "worker" for some other Id
- Id -- Id for which this is a worker
-
-#ifdef DPH
- | PodId Int -- The dimension of the PODs context
- Int -- Which specialisation of InfoType is
- -- bind. ToDo(hilly): Int is a little messy
- -- and has a restricted range---change.
- Id -- One of the aboves Ids.
-#endif {- Data Parallel Haskell -}
-
-type ConTag = Int
-type DictVar = Id
-type DictFun = Id
-type DataCon = Id
-\end{code}
-
-For Ids whose names must be known/deducible in other modules, we have
-to conjure up their worker's names (and their worker's worker's
-names... etc) in a known systematic way.
-
-%************************************************************************
-%* *
-\subsection[Id-documentation]{Documentation}
-%* *
-%************************************************************************
-
-[A BIT DATED [WDP]]
-
-The @Id@ datatype describes {\em values}. The basic things we want to
-know: (1)~a value's {\em type} (@getIdUniType@ is a very common
-operation in the compiler); and (2)~what ``flavour'' of value it might
-be---for example, it can be terribly useful to know that a value is a
-class method.
-
-\begin{description}
-%----------------------------------------------------------------------
-\item[@DataConId@:] For the data constructors declared by a @data@
-declaration. Their type is kept in {\em two} forms---as a regular
-@UniType@ (in the usual place), and also in its constituent pieces (in
-the ``details''). We are frequently interested in those pieces.
-
-%----------------------------------------------------------------------
-\item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
-the infinite family of tuples.
-
-%----------------------------------------------------------------------
-\item[@ImportedId@:] These are values defined outside this module.
-{\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
-@FullName@). 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.
-Theoretically, they could be floated inwards, but there's no known
-advantage in doing so. This way, we can keep them with the same
-@Unique@ throughout (no cloning), and, in general, we don't have to be
-so paranoid about them.
-
-In particular, we had the following problem generating an interface:
-We have to ``stitch together'' info (1)~from the typechecker-produced
-global-values list (GVE) and (2)~from the STG code [which @Ids@ have
-what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
-between (1) and (2), you're sunk!
-
-%----------------------------------------------------------------------
-\item[@ClassOpId@:] A selector from a dictionary; it may select either
-a method or a dictionary for one of the class's superclasses.
-
-%----------------------------------------------------------------------
-\item[@DictFunId@:]
-
-@mkDictFunId [a,b..] theta C T@ is the function derived from the
-instance declaration
-
- instance theta => C (T a b ..) where
- ...
-
-It builds function @Id@ which maps dictionaries for theta,
-to a dictionary for C (T a b ..).
-
-*Note* that with the ``Mark Jones optimisation'', the theta may
-include dictionaries for the immediate superclasses of C at the type
-(T a b ..).
-
-%----------------------------------------------------------------------
-\item[@InstId@:]
-
-%----------------------------------------------------------------------
-\item[@SpecId@:]
-
-%----------------------------------------------------------------------
-\item[@WorkerId@:]
-
-%----------------------------------------------------------------------
-\item[@LocalId@:] A purely-local value, e.g., a function argument,
-something defined in a @where@ clauses, ... --- but which appears in
-the original program text.
-
-%----------------------------------------------------------------------
-\item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
-the original program text; these are introduced by the compiler in
-doing its thing.
-
-%----------------------------------------------------------------------
-\item[@SpecPragmaId@:] Introduced by the compiler to record
-Specialisation pragmas. It is dead code which MUST NOT be removed
-before specialisation.
-\end{description}
-
-Further remarks:
-\begin{enumerate}
-%----------------------------------------------------------------------
-\item
-
-@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
-@ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
-properties:
-\begin{itemize}
-\item
-They have no free type variables, so if you are making a
-type-variable substitution you don't need to look inside them.
-\item
-They are constants, so they are not free variables. (When the STG
-machine makes a closure, it puts all the free variables in the
-closure; the above are not required.)
-\end{itemize}
-Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
-properties, but they may not.
-\end{enumerate}
-
-
-%************************************************************************
-%* *
-\subsection[Id-general-funs]{General @Id@-related functions}
-%* *
-%************************************************************************
-
-\begin{code}
-isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True
-isDataCon (Id _ _ _ (TupleConId _)) = True
-isDataCon (Id _ _ _ (SpecId unspec _ _)) = isDataCon unspec
-#ifdef DPH
-isDataCon (ProcessorCon _ _) = True
-isDataCon (PodId _ _ id ) = isDataCon id
-#endif {- Data Parallel Haskell -}
-isDataCon other = False
-
-isTupleCon (Id _ _ _ (TupleConId _)) = True
-isTupleCon (Id _ _ _ (SpecId unspec _ _)) = isTupleCon unspec
-#ifdef DPH
-isTupleCon (PodId _ _ id) = isTupleCon id
-#endif {- Data Parallel Haskell -}
-isTupleCon other = False
-
-isNullaryDataCon data_con
- = isDataCon data_con
- && (case arityMaybe (getIdArity data_con) of
- Just a -> a == 0
- _ -> panic "isNullaryDataCon")
-
-isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _))
- = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- Just (unspec, ty_maybes)
-isSpecId_maybe other_id
- = Nothing
-
-isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId _ specinfo _))
- = Just specinfo
-isSpecPragmaId_maybe other_id
- = Nothing
-
-#ifdef DPH
-isProcessorCon (ProcessorCon _ _) = True
-isProcessorCon (PodId _ _ id) = isProcessorCon id
-isProcessorCon other = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-@toplevelishId@ tells whether an @Id@ {\em may} be defined in a
-nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
-defined at top level (returns @True@). This is used to decide whether
-the @Id@ is a candidate free variable. NB: you are only {\em sure}
-about something if it returns @True@!
-
-\begin{code}
-toplevelishId :: Id -> Bool
-idHasNoFreeTyVars :: Id -> Bool
-
-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 (ClassOpId _ _) = 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
-#ifdef DPH
- chk (ProcessorCon _ _) = True
- chk (PodId _ _ id) = toplevelishId id
-#endif {- Data Parallel Haskell -}
-
-idHasNoFreeTyVars (Id _ _ info details)
- = chk details
- where
- chk (DataConId _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (ImportedId _) = True
- chk (PreludeId _) = True
- chk (TopLevId _) = True
- chk (SuperDictSelId _ _) = True
- chk (ClassOpId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _ _) = True
- chk (ConstMethodId _ _ _ _ _) = True
- chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
- chk (InstId _) = False -- these are local
- chk (SpecId _ _ no_free_tvs) = no_free_tvs
- chk (LocalId _ no_free_tvs) = no_free_tvs
- chk (SysLocalId _ no_free_tvs) = no_free_tvs
- chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
-#ifdef DPH
- chk (ProcessorCon _ _) = True
- chk (PodId _ _ id) = idHasNoFreeTyVars id
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-isTopLevId (Id _ _ _ (TopLevId _)) = True
-#ifdef DPH
-isTopLevId (PodId _ _ id) = isTopLevId id
-#endif {- Data Parallel Haskell -}
-isTopLevId other = False
-
--- an "invented" one is a top-level Id, must be globally visible, etc.,
--- but it's slightly different in that it was "conjured up".
--- This handles workers fine, but may need refinement for other
--- conjured-up things (e.g., specializations)
--- NB: Only used in DPH now (93/08/20)
-
-#ifdef DPH
-ToDo: DPH
-isInventedTopLevId (TopLevId _ n _ _) = isInventedFullName n
-isInventedTopLevId (SpecId _ _ _) = True
-isInventedTopLevId (WorkerId _) = True
-isInventedTopLevId (PodId _ _ id) = isInventedTopLevId id
-isInventedTopLevId other = False
-#endif {- Data Parallel Haskell -}
-
-isImportedId (Id _ _ _ (ImportedId _)) = True
-#ifdef DPH
-isImportedId (PodId _ _ id) = isImportedId id
-#endif {- Data Parallel Haskell -}
-isImportedId other = False
-
-isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info)
-#ifdef DPH
-isBottomingId (PodId _ _ id) = isBottomingId id
-#endif {- Data Parallel Haskell -}
---isBottomingId other = False
-
-isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True
-#ifdef DPH
-isSysLocalId (PodId _ _ id) = isSysLocalId id
-#endif {- Data Parallel Haskell -}
-isSysLocalId other = False
-
-isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True
-#ifdef DPH
-isSpecPragmaId (PodId _ _ id) = isSpecPragmaId id
-#endif {- Data Parallel Haskell -}
-isSpecPragmaId other = False
-
-isClassOpId (Id _ _ _ (ClassOpId _ _)) = True
-isClassOpId _ = False
-
-isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err)
-#ifdef DPH
-isDefaultMethodId_maybe (PodId _ _ id) = isDefaultMethodId_maybe id
-#endif {- Data Parallel Haskell -}
-isDefaultMethodId_maybe other = Nothing
-
-isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True
-#ifdef DPH
-isDictFunId (PodId _ _ id) = isDictFunId id
-#endif {- Data Parallel Haskell -}
-isDictFunId other = False
-
-isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop)
-#ifdef DPH
-isConstMethodId_maybe (PodId _ _ id) = isConstMethodId_maybe id
-#endif {- Data Parallel Haskell -}
-isConstMethodId_maybe other = Nothing
-
-isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst
-#ifdef DPH
-isInstId_maybe (PodId _ _ id) = isInstId_maybe id
-#endif {- Data Parallel Haskell -}
-isInstId_maybe other_id = Nothing
-
-isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc)
-#ifdef DPH
-isSuperDictSelId_maybe (PodId _ _ id) = isSuperDictSelId_maybe id
-#endif {- Data Parallel Haskell -}
-isSuperDictSelId_maybe other_id = Nothing
-
-isWorkerId (Id _ _ _ (WorkerId _)) = True
-#ifdef DPH
-isWorkerId (PodId _ _ id) = isWorkerId id
-#endif {- Data Parallel Haskell -}
-isWorkerId other = False
-
-isWrapperId id = workerExists (getIdStrictness id)
-\end{code}
-
-\begin{code}
-pprIdInUnfolding :: IdSet -> Id -> Pretty
-
-pprIdInUnfolding in_scopes v
- = let
- v_ty = getIdUniType v
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- pprUnique (getTheUnique 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))
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details) = v
- in
- 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
- DataConId _ _ _ _ _ _ -> pp_full_name
-
- -- class-ish things: class already recorded as "mentioned"
- SuperDictSelId c sc
- -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
- ClassOpId c o
- -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
- DefaultMethodId c o _
- -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
-
- -- instance-ish things: should we try to figure out
- -- *exactly* which extra instances have to be exported? (ToDo)
- DictFunId c t _ _
- -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
- ConstMethodId c t o _ _
- -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- pp = pprIdInUnfolding in_scopes unspec
- in
- ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
- ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
- ppRbrack]
-
- WorkerId unwrkr
- -> let
- pp = pprIdInUnfolding in_scopes unwrkr
- in
- ppBeside (ppPStr SLIT("_WRKR_ ")) pp
-
- -- anything else? we're nae interested
- other_id -> panic "pprIdInUnfolding:mystery Id"
- where
- ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
-
- pp_full_name
- = let
- (m_str, n_str) = getOrigName v
-
- pp_n =
- if isAvarop n_str || isAconop n_str then
- ppBesides [ppLparen, ppPStr n_str, ppRparen]
- else
- ppPStr n_str
- in
- if fromPreludeCore v then
- pp_n
- else
- ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-
- pp_class :: Class -> Pretty
- pp_class_op :: ClassOp -> Pretty
- pp_type :: UniType -> Pretty
- pp_ty_maybe :: Maybe UniType -> Pretty
-
- pp_class clas = ppr ppr_Unfolding clas
- pp_class_op op = ppr ppr_Unfolding op
-
- pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
-
- pp_ty_maybe Nothing = ppPStr SLIT("_N_")
- pp_ty_maybe (Just t) = pp_type t
-\end{code}
-
-@whatsMentionedInId@ ferrets out the types/classes/instances on which
-this @Id@ depends. If this Id is to appear in an interface, then
-those entities had Jolly Well be in scope. Someone else up the
-call-tree decides that.
-
-\begin{code}
-whatsMentionedInId
- :: IdSet -- Ids known to be in scope
- -> Id -- Id being processed
- -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
-
-whatsMentionedInId in_scopes v
- = let
- v_ty = getIdUniType v
-
- (tycons, clss)
- = getMentionedTyConsAndClassesFromUniType v_ty
-
- result0 id_bag = (id_bag, tycons, clss)
-
- result1 ids tcs cs
- = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
- tcs `unionBags` tycons,
- cs `unionBags` clss)
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- result0 emptyBag -- v not added to "mentioned"
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details) = v
- in
- case v_details of
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
- in
- result1 ids2 tcs2 cs2
-
- WorkerId unwrkr
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
- in
- result1 ids2 tcs2 cs2
-
- anything_else -> result0 (unitBag v) -- v is added to "mentioned"
-\end{code}
-
-Tell them who my wrapper function is.
-\begin{code}
-myWrapperMaybe :: Id -> Maybe Id
-
-myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper)) = Just my_wrapper
-myWrapperMaybe other_id = Nothing
-\end{code}
-
-\begin{code}
-unfoldingUnfriendlyId -- return True iff it is definitely a bad
- :: Id -- idea to export an unfolding that
- -> Bool -- mentions this Id. Reason: it cannot
- -- possibly be seen in another module.
-
-unfoldingUnfriendlyId id
- | not (externallyVisibleId id) -- that settles that...
- = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
- = class_thing wrapper
- where
- -- "class thing": If we're going to use this worker Id in
- -- an interface, we *have* to be able to untangle the wrapper's
- -- strictness when reading it back in. At the moment, this
- -- is not always possible: in precisely those cases where
- -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
- class_thing (Id _ _ _ (SuperDictSelId _ _)) = True
- class_thing (Id _ _ _ (ClassOpId _ _)) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
- class_thing other = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
- -- a SPEC of a DictFunId can end up w/ gratuitous
- -- 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
- --)
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
- = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun -- similar deal...
- --)
-
-unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
- -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _ _)
- = not (isGroundTy ty)
-\end{code}
-
-@externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id?
-
-We need the @toplevelishId@ check as well as @isExported@ for when we
-compile instance declarations in the prelude. @DictFunIds@ are
-``exported'' if either their class or tycon is exported, but, in
-compiling the prelude, the compiler may not recognise that as true.
-
-\begin{code}
-externallyVisibleId :: Id -> Bool
-
-externallyVisibleId id@(Id _ _ _ details)
- = if isLocallyDefined id then
- toplevelishId id && isExported id && not (weird_datacon details)
- else
- not (weird_tuplecon details)
- -- if visible here, it must be visible elsewhere, too.
- where
- -- If it's a DataCon, it's not enough to know it (meaning
- -- its TyCon) is exported; we need to know that it might
- -- be visible outside. Consider:
- --
- -- data Foo a = Mumble | BigFoo a WeirdLocalType
- --
- -- We can't tell the outside world *anything* about Foo, because
- -- of WeirdLocalType; but we need to know this when asked if
- -- "Mumble" is externally visible...
-
- weird_datacon (DataConId _ _ _ _ _ tycon)
- = maybeToBool (maybePurelyLocalTyCon tycon)
- weird_datacon not_a_datacon_therefore_not_weird = False
-
- weird_tuplecon (TupleConId arity)
- = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
- weird_tuplecon _ = False
-\end{code}
-
-\begin{code}
-idWantsToBeINLINEd :: Id -> Bool
-
-idWantsToBeINLINEd id
- = case (getIdUnfolding id) of
- IWantToBeINLINEd _ -> True
- _ -> False
-\end{code}
-
-For @unlocaliseId@: See the brief commentary in
-\tr{simplStg/SimplStg.lhs}.
-
-\begin{code}
-unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
-
-unlocaliseId mod (Id u ty info (TopLevId fn))
- = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
-
-unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u ty info (TopLevId full_name))
-
-unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
- = --false?: on PreludeGlaST: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u ty info (TopLevId full_name))
-
-unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
- = case unlocalise_parent mod u unspec of
- Nothing -> Nothing
- Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
-
-unlocaliseId mod (Id u ty info (WorkerId unwrkr))
- = case unlocalise_parent mod u unwrkr of
- Nothing -> Nothing
- Just xx -> Just (Id u ty info (WorkerId xx))
-
-unlocaliseId mod (Id u ty info (InstId inst))
- = Just (Id u ty info (TopLevId full_name))
- -- type might be wrong, but it hardly matters
- -- at this stage (just before printing C) ToDo
- where
- name = let (bit1:bits) = getInstNamePieces True inst in
- _CONCAT_ (bit1 : [ _CONS_ '.' b | b <- bits ])
-
- full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-#ifdef DPH
-unlocaliseId mod (PodId dim ity id)
- = case (unlocaliseId mod id) of
- Just id' -> Just (PodId dim ity id')
- Nothing -> Nothing
-#endif {- Data Parallel Haskell -}
-
-unlocaliseId mod other_id = Nothing
-
---------------------
--- we have to be Very Careful for workers/specs of
--- local functions!
-
-unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq ty info (TopLevId full_name))
-
-unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq ty info (TopLevId full_name))
-
-unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
- -- we're OK otherwise
-\end{code}
-
-CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
-`Top-levelish Ids'' cannot have any free type variables, so applying
-the type-env cannot have any effect. (NB: checked in CoreLint?)
-
-The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
-former ``should be'' the usual crunch point.
-
-\begin{code}
-applyTypeEnvToId :: TypeEnv -> Id -> Id
-
-applyTypeEnvToId type_env id@(Id u ty info details)
- | idHasNoFreeTyVars id
- = id
- | otherwise
- = apply_to_Id ( \ ty ->
- applyTypeEnvToTy type_env ty
- ) id
-\end{code}
-
-\begin{code}
-apply_to_Id :: (UniType -> UniType)
- -> 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)
- 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????
- where
- apply_to_maybe Nothing = Nothing
- apply_to_maybe (Just ty) = Just (ty_fn ty)
-
- apply_to_details (WorkerId unwrkr)
- = let
- new_unwrkr = apply_to_Id ty_fn unwrkr
- in
- WorkerId new_unwrkr
-
-#ifdef DPH
- apply_to_details (PodId d ity id )
- = PodId d ity (apply_to_Id ty_fn id)
-#endif {- Data Parallel Haskell -}
-
- apply_to_details other = other
-\end{code}
-
-Sadly, I don't think the one using the magic typechecker substitution
-can be done with @apply_to_Id@. Here we go....
-
-Strictness is very important here. We can't leave behind thunks
-with pointers to the substitution: it {\em must} be single-threaded.
-
-\begin{code}
-applySubstToId :: Subst -> Id -> (Subst, Id)
-
-applySubstToId subst id@(Id u ty info details)
- -- *cannot* have a "idHasNoFreeTyVars" get-out clause
- -- because, in the typechecker, we are still
- -- *concocting* the types.
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
- 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)
- = case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId new_inst) }
-
- apply_to_details subst new_ty (SpecId unspec ty_maybes _)
- = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
- case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
- (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
- -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
- where
- apply_to_maybe subst Nothing = (subst, Nothing)
- apply_to_maybe subst (Just ty)
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- (s2, Just new_ty) }
-
- apply_to_details subst _ (WorkerId unwrkr)
- = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
- (s2, WorkerId new_unwrkr) }
-
- apply_to_details subst _ other = (subst, other)
-
-#ifdef DPH
-applySubstToId (PodId d ity id )
- = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id))
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING]
-
-getIdNamePieces show_uniqs (Id u ty info details)
- = case details of
- DataConId n _ _ _ _ _ ->
- case (getOrigName n) of { (mod, name) ->
- if fromPrelude mod then [name] else [mod, name] }
-
- TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))]
-
- ImportedId n -> get_fullname_pieces n
- PreludeId n -> get_fullname_pieces n
- TopLevId n -> get_fullname_pieces n
-
- SuperDictSelId c sc ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getOrigName sc) of { (sc_mod, sc_name) ->
- let
- c_bits = if fromPreludeCore c
- then [c_name]
- else [c_mod, c_name]
-
- sc_bits= if fromPreludeCore sc
- then [sc_name]
- else [sc_mod, sc_name]
- in
- [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
-
- ClassOpId 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]
- } }
-
- DefaultMethodId clas op _ ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if fromPreludeCore 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
- then [c_name]
- else [c_mod, c_name]
-
- ty_bits = getTypeString ty
- 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 ->
- [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
-
- -- if the unspecialised equiv is "top-level",
- -- the name must be concocted from its name and the
- -- names of the types to which specialised...
-
- SpecId unspec ty_maybes _ ->
- getIdNamePieces show_uniqs unspec ++ (
- if not (toplevelishId unspec)
- then [showUnique u]
- else concat (map typeMaybeString ty_maybes)
- )
-
- WorkerId unwrkr ->
- getIdNamePieces show_uniqs unwrkr ++ (
- if not (toplevelishId unwrkr)
- then [showUnique u]
- else [SLIT("wrk")] -- show u
- )
-
- InstId inst -> getInstNamePieces show_uniqs inst
- LocalId n _ -> let local = getLocalName n in
- if show_uniqs then [local, showUnique u] else [local]
- SysLocalId n _ -> [getLocalName n, showUnique u]
- SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-
-#ifdef DPH
- ProcessorCon a _ -> ["MkProcessor" ++ (show a)]
- PodId n ity id -> getIdNamePieces show_uniqs id ++
- ["mapped", "POD" ++ (show n), show ity]
-#endif {- Data Parallel Haskell -}
-
-get_fullname_pieces :: FullName -> [FAST_STRING]
-get_fullname_pieces n
- = BIND (getOrigName n) _TO_ (mod, name) ->
- if fromPrelude mod
- then [name]
- else [mod, name]
- BEND
-\end{code}
-
-Really Inst-ish, but only used in this module...
-\begin{code}
-getInstNamePieces :: Bool -> Inst -> [FAST_STRING]
-
-getInstNamePieces show_uniqs (Dict u clas ty _)
- = let (mod, nm) = getOrigName clas in
- if fromPreludeCore clas
- then [SLIT("d"), nm, showUnique u]
- else [SLIT("d"), mod, nm, showUnique u]
-
-getInstNamePieces show_uniqs (Method u id tys _)
- = let local = getIdNamePieces show_uniqs id in
- if show_uniqs then local ++ [showUnique u] else local
-
-getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Id-type-funs]{Type-related @Id@ functions}
-%* *
-%************************************************************************