ghc/compiler/basicTypes/Id.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Id]{@Ids@: Value and constructor identifiers}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Id {- (
  10         GenId, Id(..),          -- Abstract
  11         StrictnessMark(..),     -- An enumaration
  12         ConTag(..), DictVar(..), DictFun(..), DataCon(..),
  13
  14         -- CONSTRUCTION
  15         mkSysLocal, mkUserLocal,
  16         mkSpecPragmaId,
  17         mkSpecId, mkSameSpecCon,
  18         selectIdInfoForSpecId,
  19         mkTemplateLocals,
  20         mkImported, mkPreludeId,
  21         mkDataCon, mkTupleCon,
  22         mkIdWithNewUniq,
  23         mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
  24         mkConstMethodId, getConstMethodId,
  25
  26         updateIdType,
  27         mkId, mkDictFunId, mkInstId,
  28         mkWorkerId,
  29         localiseId,
  30
  31         -- DESTRUCTION
  32         idType,
  33         getIdInfo, replaceIdInfo,
  34         getPragmaInfo,
  35         getIdPrimRep, getInstIdModule,
  36         getMentionedTyConsAndClassesFromId,
  37         getDataConTag,
  38         getDataConSig, getInstantiatedDataConSig,
  39
  40         getDataConTyCon,
  41
  42         -- PREDICATES
  43         isDataCon, isTupleCon,
  44         isSpecId_maybe, isSpecPragmaId_maybe,
  45         toplevelishId, externallyVisibleId,
  46         isTopLevId, isWorkerId, isWrapperId,
  47         isImportedId, isSysLocalId,
  48         isBottomingId,
  49         isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
  50         isDictFunId,
  51 --???   isInstId_maybe,
  52         isConstMethodId_maybe,
  53         cmpId_withSpecDataCon,
  54         myWrapperMaybe,
  55         whatsMentionedInId,
  56         unfoldingUnfriendlyId,  -- ToDo: rm, eventually
  57         idWantsToBeINLINEd,
  58 --      dataConMentionsNonPreludeTyCon,
  59
  60         -- SUBSTITUTION
  61         applySubstToId, applyTypeEnvToId,
  62 -- not exported:        apply_to_Id, -- please don't use this, generally
  63
  64         -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
  65         getIdArity, getDataConArity, addIdArity,
  66         getIdDemandInfo, addIdDemandInfo,
  67         getIdSpecialisation, addIdSpecialisation,
  68         getIdStrictness, addIdStrictness,
  69         getIdUnfolding, addIdUnfolding,
  70         getIdUpdateInfo, addIdUpdateInfo,
  71         getIdArgUsageInfo, addIdArgUsageInfo,
  72         getIdFBTypeInfo, addIdFBTypeInfo,
  73         -- don't export the types, lest OptIdInfo be dragged in!
  74
  75         -- MISCELLANEOUS
  76         unlocaliseId,
  77         fIRST_TAG,
  78         showId,
  79         pprIdInUnfolding,
  80
  81         -- "Environments" keyed off of Ids, and sets of Ids
  82         IdEnv(..),
  83         lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
  84         growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
  85         delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
  86         rngIdEnv, mapIdEnv,
  87
  88         -- and to make the interface self-sufficient...
  89         GenIdSet(..), IdSet(..)
  90     )-} where
  91
  92 import Ubiq
  93 import IdLoop   -- for paranoia checking
  94 import TyLoop   -- for paranoia checking
  95 import NameLoop -- for paranoia checking
  96
  97 import Bag
  98 import Class            ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
  99 import IdInfo
 100 import Maybes           ( maybeToBool )
 101 import NameTypes        ( mkShortName, fromPrelude, FullName, ShortName )
 102 import Name             ( Name(..) )
 103 import Outputable       ( isAvarop, isAconop, getLocalName,
 104                           isExported, ExportFlag(..) )
 105 import PragmaInfo       ( PragmaInfo(..) )
 106 import PrelMods         ( pRELUDE_BUILTIN )
 107 import PprType          ( GenType, GenTyVar,
 108                           getTypeString, typeMaybeString, specMaybeTysSuffix )
 109 import PprStyle
 110 import Pretty
 111 import SrcLoc           ( mkBuiltinSrcLoc )
 112 import TyCon            ( TyCon, mkTupleTyCon, getTyConDataCons )
 113 import Type             ( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy,
 114                           applyTyCon, isPrimType, instantiateTy,
 115                           GenType, ThetaType(..), TauType(..), Type(..) )
 116 import TyVar            ( GenTyVar, alphaTyVars )
 117 import UniqFM
 118 import UniqSet          ( UniqSet(..) )
 119 import Unique           ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
 120 import Util             ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
 121 \end{code}
 122
 123 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 124 follow.
 125
 126 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
 127 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
 128 strictness).  The essential info about different kinds of @Ids@ is
 129 in its @IdDetails@.
 130
 131 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 132
 133 \begin{code}
 134 data GenId ty = Id
 135         Unique          -- Key for fast comparison
 136         ty              -- Id's type; used all the time;
 137         IdDetails       -- Stuff about individual kinds of Ids.
 138         PragmaInfo      -- Properties of this Id requested by programmer
 139                         -- eg specialise-me, inline-me
 140         IdInfo          -- Properties of this Id deduced by compiler
 141
 142 type Id = GenId Type
 143
 144 data StrictnessMark = MarkedStrict | NotMarkedStrict
 145
 146 data IdDetails
 147
 148   ---------------- Local values
 149
 150   = LocalId     ShortName       -- mentioned by the user
 151                 Bool            -- True <=> no free type vars
 152
 153   | SysLocalId  ShortName       -- made up by the compiler
 154                 Bool            -- as for LocalId
 155
 156   | SpecPragmaId ShortName      -- introduced by the compiler
 157                  (Maybe Id)     -- for explicit specid in pragma
 158                  Bool           -- as for LocalId
 159
 160   ---------------- Global values
 161
 162   | ImportedId  FullName        -- Id imported from an interface
 163
 164   | PreludeId   FullName        -- things < Prelude that compiler "knows" about
 165
 166   | TopLevId    FullName        -- Top-level in the orig source pgm
 167                                 -- (not moved there by transformations).
 168
 169         -- a TopLevId's type may contain free type variables, if
 170         -- the monomorphism restriction applies.
 171
 172   ---------------- Data constructors
 173
 174   | DataConId   FullName
 175                 ConTag
 176                 [StrictnessMark] -- Strict args; length = arity
 177
 178                 [TyVar] [(Class,Type)] [Type] TyCon
 179                                 -- the type is:
 180                                 -- forall tyvars . theta_ty =>
 181                                 --    unitype_1 -> ... -> unitype_n -> tycon tyvars
 182
 183   | TupleConId  Int             -- Its arity
 184
 185   ---------------- Things to do with overloading
 186
 187   | SuperDictSelId              -- Selector for superclass dictionary
 188                 Class           -- The class (input dict)
 189                 Class           -- The superclass (result dict)
 190
 191   | MethodSelId Class           -- An overloaded class operation, with
 192                                 -- a fully polymorphic type.  Its code
 193                                 -- just selects a method from the
 194                                 -- dictionary.  The class.
 195                 ClassOp         -- The operation
 196
 197         -- NB: The IdInfo for a MethodSelId has all the info about its
 198         -- related "constant method Ids", which are just
 199         -- specialisations of this general one.
 200
 201   | DefaultMethodId             -- Default method for a particular class op
 202                 Class           -- same class, <blah-blah> info as MethodSelId
 203                 ClassOp         -- (surprise, surprise)
 204                 Bool            -- True <=> I *know* this default method Id
 205                                 -- is a generated one that just says
 206                                 -- `error "No default method for <op>"'.
 207
 208                                 -- see below
 209   | DictFunId   Class           -- A DictFun is uniquely identified
 210                 Type            -- by its class and type; this type has free type vars,
 211                                 -- whose identity is irrelevant.  Eg Class = Eq
 212                                 --                                   Type  = Tree a
 213                                 -- The "a" is irrelevant.  As it is too painful to
 214                                 -- actually do comparisons that way, we kindly supply
 215                                 -- a Unique for that purpose.
 216                 Bool            -- True <=> from an instance decl in this mod
 217                 FAST_STRING     -- module where instance came from
 218
 219                                 -- see below
 220   | ConstMethodId               -- A method which depends only on the type of the
 221                                 -- instance, and not on any further dictionaries etc.
 222                 Class           -- Uniquely identified by:
 223                 Type            -- (class, type, classop) triple
 224                 ClassOp
 225                 Bool            -- True <=> from an instance decl in this mod
 226                 FAST_STRING     -- module where instance came from
 227
 228   | InstId      ShortName       -- An instance of a dictionary, class operation,
 229                                 -- or overloaded value
 230
 231   | SpecId                      -- A specialisation of another Id
 232                 Id              -- Id of which this is a specialisation
 233                 [Maybe Type]    -- Types at which it is specialised;
 234                                 -- A "Nothing" says this type ain't relevant.
 235                 Bool            -- True <=> no free type vars; it's not enough
 236                                 -- to know about the unspec version, because
 237                                 -- we may specialise to a type w/ free tyvars
 238                                 -- (i.e., in one of the "Maybe Type" dudes).
 239
 240   | WorkerId                    -- A "worker" for some other Id
 241                 Id              -- Id for which this is a worker
 242
 243
 244 type ConTag     = Int
 245 type DictVar    = Id
 246 type DictFun    = Id
 247 type DataCon    = Id
 248 \end{code}
 249
 250
 251 DictFunIds are generated from instance decls.
 252 \begin{verbatim}
 253         class Foo a where
 254           op :: a -> a -> Bool
 255
 256         instance Foo a => Foo [a] where
 257           op = ...
 258 \end{verbatim}
 259 generates the dict fun id decl
 260 \begin{verbatim}
 261         dfun.Foo.[*] = \d -> ...
 262 \end{verbatim}
 263 The dfun id is uniquely named by the (class, type) pair.  Notice, it
 264 isn't a (class,tycon) pair any more, because we may get manually or
 265 automatically generated specialisations of the instance decl:
 266 \begin{verbatim}
 267         instance Foo [Int] where
 268           op = ...
 269 \end{verbatim}
 270 generates
 271 \begin{verbatim}
 272         dfun.Foo.[Int] = ...
 273 \end{verbatim}
 274 The type variables in the name are irrelevant; we print them as stars.
 275
 276
 277 Constant method ids are generated from instance decls where
 278 there is no context; that is, no dictionaries are needed to
 279 construct the method.  Example
 280 \begin{verbatim}
 281         instance Foo Int where
 282           op = ...
 283 \end{verbatim}
 284 Then we get a constant method
 285 \begin{verbatim}
 286         Foo.op.Int = ...
 287 \end{verbatim}
 288
 289 It is possible, albeit unusual, to have a constant method
 290 for an instance decl which has type vars:
 291 \begin{verbatim}
 292         instance Foo [a] where
 293           op []     ys = True
 294           op (x:xs) ys = False
 295 \end{verbatim}
 296 We get the constant method
 297 \begin{verbatim}
 298         Foo.op.[*] = ...
 299 \end{verbatim}
 300 So a constant method is identified by a class/op/type triple.
 301 The type variables in the type are irrelevant.
 302
 303
 304 For Ids whose names must be known/deducible in other modules, we have
 305 to conjure up their worker's names (and their worker's worker's
 306 names... etc) in a known systematic way.
 307
 308
 309 %************************************************************************
 310 %*                                                                      *
 311 \subsection[Id-documentation]{Documentation}
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 [A BIT DATED [WDP]]
 316
 317 The @Id@ datatype describes {\em values}.  The basic things we want to
 318 know: (1)~a value's {\em type} (@idType@ is a very common
 319 operation in the compiler); and (2)~what ``flavour'' of value it might
 320 be---for example, it can be terribly useful to know that a value is a
 321 class method.
 322
 323 \begin{description}
 324 %----------------------------------------------------------------------
 325 \item[@DataConId@:] For the data constructors declared by a @data@
 326 declaration.  Their type is kept in {\em two} forms---as a regular
 327 @Type@ (in the usual place), and also in its constituent pieces (in
 328 the ``details''). We are frequently interested in those pieces.
 329
 330 %----------------------------------------------------------------------
 331 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
 332 the infinite family of tuples.
 333
 334 %----------------------------------------------------------------------
 335 \item[@ImportedId@:] These are values defined outside this module.
 336 {\em Everything} we want to know about them must be stored here (or in
 337 their @IdInfo@).
 338
 339 %----------------------------------------------------------------------
 340 \item[@PreludeId@:] ToDo
 341
 342 %----------------------------------------------------------------------
 343 \item[@TopLevId@:] These are values defined at the top-level in this
 344 module; i.e., those which {\em might} be exported (hence, a
 345 @FullName@).  It does {\em not} include those which are moved to the
 346 top-level through program transformations.
 347
 348 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
 349 Theoretically, they could be floated inwards, but there's no known
 350 advantage in doing so.  This way, we can keep them with the same
 351 @Unique@ throughout (no cloning), and, in general, we don't have to be
 352 so paranoid about them.
 353
 354 In particular, we had the following problem generating an interface:
 355 We have to ``stitch together'' info (1)~from the typechecker-produced
 356 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
 357 what arities].  If the @Uniques@ on the @TopLevIds@ can {\em change}
 358 between (1) and (2), you're sunk!
 359
 360 %----------------------------------------------------------------------
 361 \item[@MethodSelId@:] A selector from a dictionary; it may select either
 362 a method or a dictionary for one of the class's superclasses.
 363
 364 %----------------------------------------------------------------------
 365 \item[@DictFunId@:]
 366
 367 @mkDictFunId [a,b..] theta C T@ is the function derived from the
 368 instance declaration
 369
 370         instance theta => C (T a b ..) where
 371                 ...
 372
 373 It builds function @Id@ which maps dictionaries for theta,
 374 to a dictionary for C (T a b ..).
 375
 376 *Note* that with the ``Mark Jones optimisation'', the theta may
 377 include dictionaries for the immediate superclasses of C at the type
 378 (T a b ..).
 379
 380 %----------------------------------------------------------------------
 381 \item[@InstId@:]
 382
 383 %----------------------------------------------------------------------
 384 \item[@SpecId@:]
 385
 386 %----------------------------------------------------------------------
 387 \item[@WorkerId@:]
 388
 389 %----------------------------------------------------------------------
 390 \item[@LocalId@:] A purely-local value, e.g., a function argument,
 391 something defined in a @where@ clauses, ... --- but which appears in
 392 the original program text.
 393
 394 %----------------------------------------------------------------------
 395 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
 396 the original program text; these are introduced by the compiler in
 397 doing its thing.
 398
 399 %----------------------------------------------------------------------
 400 \item[@SpecPragmaId@:] Introduced by the compiler to record
 401 Specialisation pragmas. It is dead code which MUST NOT be removed
 402 before specialisation.
 403 \end{description}
 404
 405 Further remarks:
 406 \begin{enumerate}
 407 %----------------------------------------------------------------------
 408 \item
 409
 410 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
 411 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 412 properties:
 413 \begin{itemize}
 414 \item
 415 They have no free type variables, so if you are making a
 416 type-variable substitution you don't need to look inside them.
 417 \item
 418 They are constants, so they are not free variables.  (When the STG
 419 machine makes a closure, it puts all the free variables in the
 420 closure; the above are not required.)
 421 \end{itemize}
 422 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
 423 properties, but they may not.
 424 \end{enumerate}
 425
 426 %************************************************************************
 427 %*                                                                      *
 428 \subsection[Id-general-funs]{General @Id@-related functions}
 429 %*                                                                      *
 430 %************************************************************************
 431
 432 \begin{code}
 433 unsafeGenId2Id :: GenId ty -> Id
 434 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
 435
 436 isDataCon id = is_data (unsafeGenId2Id id)
 437  where
 438   is_data (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
 439   is_data (Id _ _ (TupleConId _) _ _)            = True
 440   is_data (Id _ _ (SpecId unspec _ _) _ _)       = is_data unspec
 441   is_data other                                  = False
 442
 443
 444 isTupleCon id = is_tuple (unsafeGenId2Id id)
 445  where
 446   is_tuple (Id _ _ (TupleConId _) _ _)           = True
 447   is_tuple (Id _ _ (SpecId unspec _ _) _ _)      = is_tuple unspec
 448   is_tuple other                                 = False
 449
 450 {-LATER:
 451 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
 452   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 453     Just (unspec, ty_maybes)
 454 isSpecId_maybe other_id
 455   = Nothing
 456
 457 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
 458   = Just specid
 459 isSpecPragmaId_maybe other_id
 460   = Nothing
 461 -}
 462 \end{code}
 463
 464 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
 465 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
 466 defined at top level (returns @True@).  This is used to decide whether
 467 the @Id@ is a candidate free variable.  NB: you are only {\em sure}
 468 about something if it returns @True@!
 469
 470 \begin{code}
 471 toplevelishId       :: Id -> Bool
 472 idHasNoFreeTyVars   :: Id -> Bool
 473
 474 toplevelishId (Id _ _ details _ _)
 475   = chk details
 476   where
 477     chk (DataConId _ _ _ _ _ _ _) = True
 478     chk (TupleConId _)            = True
 479     chk (ImportedId _)            = True
 480     chk (PreludeId  _)            = True
 481     chk (TopLevId   _)            = True        -- NB: see notes
 482     chk (SuperDictSelId _ _)      = True
 483     chk (MethodSelId _ _)                 = True
 484     chk (DefaultMethodId _ _ _)   = True
 485     chk (DictFunId     _ _ _ _)   = True
 486     chk (ConstMethodId _ _ _ _ _) = True
 487     chk (SpecId unspec _ _)       = toplevelishId unspec
 488                                   -- depends what the unspecialised thing is
 489     chk (WorkerId unwrkr)         = toplevelishId unwrkr
 490     chk (InstId _)                = False       -- these are local
 491     chk (LocalId      _ _)        = False
 492     chk (SysLocalId   _ _)        = False
 493     chk (SpecPragmaId _ _ _)      = False
 494
 495 idHasNoFreeTyVars (Id _ _ details _ info)
 496   = chk details
 497   where
 498     chk (DataConId _ _ _ _ _ _ _) = True
 499     chk (TupleConId _)            = True
 500     chk (ImportedId _)            = True
 501     chk (PreludeId  _)            = True
 502     chk (TopLevId   _)            = True
 503     chk (SuperDictSelId _ _)      = True
 504     chk (MethodSelId _ _)                 = True
 505     chk (DefaultMethodId _ _ _)   = True
 506     chk (DictFunId     _ _ _ _)   = True
 507     chk (ConstMethodId _ _ _ _ _) = True
 508     chk (WorkerId unwrkr)         = idHasNoFreeTyVars unwrkr
 509     chk (InstId _)                = False       -- these are local
 510     chk (SpecId _     _   no_free_tvs) = no_free_tvs
 511     chk (LocalId      _   no_free_tvs) = no_free_tvs
 512     chk (SysLocalId   _   no_free_tvs) = no_free_tvs
 513     chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
 514 \end{code}
 515
 516 \begin{code}
 517 isTopLevId (Id _ _ (TopLevId _) _ _) = True
 518 isTopLevId other                     = False
 519
 520 isImportedId (Id _ _ (ImportedId _) _ _) = True
 521 isImportedId other                       = False
 522
 523 isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
 524                         -- LATER: bottomIsGuaranteed (getInfo info)
 525
 526 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
 527 isSysLocalId other                         = False
 528
 529 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
 530 isSpecPragmaId other                             = False
 531
 532 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
 533 isMethodSelId _                          = False
 534
 535 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
 536 isDefaultMethodId other                                = False
 537
 538 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
 539   = Just (cls, clsop, err)
 540 isDefaultMethodId_maybe other = Nothing
 541
 542 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
 543 isDictFunId other                            = False
 544
 545 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
 546 isConstMethodId other                                  = False
 547
 548 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
 549   = Just (cls, ty, clsop)
 550 isConstMethodId_maybe other = Nothing
 551
 552 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
 553 isSuperDictSelId_maybe other_id                           = Nothing
 554
 555 isWorkerId (Id _ _ (WorkerId _) _ _) = True
 556 isWorkerId other                     = False
 557
 558 {-LATER:
 559 isWrapperId id = workerExists (getIdStrictness id)
 560 -}
 561 \end{code}
 562
 563 \begin{code}
 564 {-LATER:
 565 pprIdInUnfolding :: IdSet -> Id -> Pretty
 566
 567 pprIdInUnfolding in_scopes v
 568   = let
 569         v_ty = idType v
 570     in
 571     -- local vars first:
 572     if v `elementOfUniqSet` in_scopes then
 573         pprUnique (getItsUnique v)
 574
 575     -- ubiquitous Ids with special syntax:
 576     else if v == nilDataCon then
 577         ppPStr SLIT("_NIL_")
 578     else if isTupleCon v then
 579         ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
 580
 581     -- ones to think about:
 582     else
 583         let
 584             (Id _ _ v_details _ _) = v
 585         in
 586         case v_details of
 587             -- these ones must have been exported by their original module
 588           ImportedId   _ -> pp_full_name
 589           PreludeId    _ -> pp_full_name
 590
 591             -- these ones' exportedness checked later...
 592           TopLevId  _ -> pp_full_name
 593           DataConId _ _ _ _ _ _ _ -> pp_full_name
 594
 595             -- class-ish things: class already recorded as "mentioned"
 596           SuperDictSelId c sc
 597             -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
 598           MethodSelId c o
 599             -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
 600           DefaultMethodId c o _
 601             -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
 602
 603             -- instance-ish things: should we try to figure out
 604             -- *exactly* which extra instances have to be exported? (ToDo)
 605           DictFunId  c t _ _
 606             -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
 607           ConstMethodId c t o _ _
 608             -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
 609
 610           -- specialisations and workers
 611           SpecId unspec ty_maybes _
 612             -> let
 613                   pp = pprIdInUnfolding in_scopes unspec
 614                in
 615                ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
 616                         ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
 617                         ppRbrack]
 618
 619           WorkerId unwrkr
 620             -> let
 621                   pp = pprIdInUnfolding in_scopes unwrkr
 622                in
 623                ppBeside (ppPStr SLIT("_WRKR_ ")) pp
 624
 625           -- anything else? we're nae interested
 626           other_id -> panic "pprIdInUnfolding:mystery Id"
 627   where
 628     ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
 629
 630     pp_full_name
 631       = let
 632             (m_str, n_str) = getOrigName v
 633
 634             pp_n =
 635               if isAvarop n_str || isAconop n_str then
 636                   ppBesides [ppLparen, ppPStr n_str, ppRparen]
 637               else
 638                   ppPStr n_str
 639         in
 640         if fromPreludeCore v then
 641             pp_n
 642         else
 643             ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
 644
 645     pp_class :: Class -> Pretty
 646     pp_class_op :: ClassOp -> Pretty
 647     pp_type :: Type -> Pretty
 648     pp_ty_maybe :: Maybe Type -> Pretty
 649
 650     pp_class    clas = ppr ppr_Unfolding clas
 651     pp_class_op op   = ppr ppr_Unfolding op
 652
 653     pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
 654
 655     pp_ty_maybe Nothing  = ppPStr SLIT("_N_")
 656     pp_ty_maybe (Just t) = pp_type t
 657 -}
 658 \end{code}
 659
 660 @whatsMentionedInId@ ferrets out the types/classes/instances on which
 661 this @Id@ depends.  If this Id is to appear in an interface, then
 662 those entities had Jolly Well be in scope.  Someone else up the
 663 call-tree decides that.
 664
 665 \begin{code}
 666 {-LATER:
 667 whatsMentionedInId
 668         :: IdSet                            -- Ids known to be in scope
 669         -> Id                               -- Id being processed
 670         -> (Bag Id, Bag TyCon, Bag Class)   -- mentioned Ids/TyCons/etc.
 671
 672 whatsMentionedInId in_scopes v
 673   = let
 674         v_ty = idType v
 675
 676         (tycons, clss)
 677           = getMentionedTyConsAndClassesFromType v_ty
 678
 679         result0 id_bag = (id_bag, tycons, clss)
 680
 681         result1 ids tcs cs
 682           = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
 683              tcs `unionBags` tycons,
 684              cs  `unionBags` clss)
 685     in
 686     -- local vars first:
 687     if v `elementOfUniqSet` in_scopes then
 688         result0 emptyBag    -- v not added to "mentioned"
 689
 690     -- ones to think about:
 691     else
 692         let
 693             (Id _ _ v_details _ _) = v
 694         in
 695         case v_details of
 696           -- specialisations and workers
 697           SpecId unspec ty_maybes _
 698             -> let
 699                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
 700                in
 701                result1 ids2 tcs2 cs2
 702
 703           WorkerId unwrkr
 704             -> let
 705                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
 706                in
 707                result1 ids2 tcs2 cs2
 708
 709           anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
 710 -}
 711 \end{code}
 712
 713 Tell them who my wrapper function is.
 714 \begin{code}
 715 {-LATER:
 716 myWrapperMaybe :: Id -> Maybe Id
 717
 718 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
 719 myWrapperMaybe other_id                           = Nothing
 720 -}
 721 \end{code}
 722
 723 \begin{code}
 724 unfoldingUnfriendlyId   -- return True iff it is definitely a bad
 725         :: Id           -- idea to export an unfolding that
 726         -> Bool         -- mentions this Id.  Reason: it cannot
 727                         -- possibly be seen in another module.
 728
 729 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
 730 {-LATER:
 731
 732 unfoldingUnfriendlyId id
 733   | not (externallyVisibleId id) -- that settles that...
 734   = True
 735
 736 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
 737   = class_thing wrapper
 738   where
 739     -- "class thing": If we're going to use this worker Id in
 740     -- an interface, we *have* to be able to untangle the wrapper's
 741     -- strictness when reading it back in.  At the moment, this
 742     -- is not always possible: in precisely those cases where
 743     -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
 744
 745     class_thing (Id _ _ (SuperDictSelId _ _) _ _)    = True
 746     class_thing (Id _ _ (MethodSelId _ _) _ _)             = True
 747     class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
 748     class_thing other                              = False
 749
 750 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
 751     -- a SPEC of a DictFunId can end up w/ gratuitous
 752     -- TyVar(Templates) in the i/face; only a problem
 753     -- if -fshow-pragma-name-errs; but we can do without the pain.
 754     -- A HACK in any case (WDP 94/05/02)
 755   = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
 756     naughty_DictFunId dfun
 757     --)
 758
 759 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
 760   = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
 761     naughty_DictFunId dfun -- similar deal...
 762     --)
 763
 764 unfoldingUnfriendlyId other_id   = False -- is friendly in all other cases
 765
 766 naughty_DictFunId :: IdDetails -> Bool
 767     -- True <=> has a TyVar(Template) in the "type" part of its "name"
 768
 769 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
 770 naughty_DictFunId (DictFunId _ ty _ _)
 771   = not (isGroundTy ty)
 772 -}
 773 \end{code}
 774
 775 @externallyVisibleId@: is it true that another module might be
 776 able to ``see'' this Id?
 777
 778 We need the @toplevelishId@ check as well as @isExported@ for when we
 779 compile instance declarations in the prelude.  @DictFunIds@ are
 780 ``exported'' if either their class or tycon is exported, but, in
 781 compiling the prelude, the compiler may not recognise that as true.
 782
 783 \begin{code}
 784 externallyVisibleId :: Id -> Bool
 785
 786 externallyVisibleId id = panic "Id.externallyVisibleId"
 787 {-LATER:
 788
 789 externallyVisibleId id@(Id _ _ details _ _)
 790   = if isLocallyDefined id then
 791         toplevelishId id && isExported id && not (weird_datacon details)
 792     else
 793         not (weird_tuplecon details)
 794         -- if visible here, it must be visible elsewhere, too.
 795   where
 796     -- If it's a DataCon, it's not enough to know it (meaning
 797     -- its TyCon) is exported; we need to know that it might
 798     -- be visible outside.  Consider:
 799     --
 800     --  data Foo a = Mumble | BigFoo a WeirdLocalType
 801     --
 802     -- We can't tell the outside world *anything* about Foo, because
 803     -- of WeirdLocalType; but we need to know this when asked if
 804     -- "Mumble" is externally visible...
 805
 806     weird_datacon (DataConId _ _ _ _ _ _ tycon)
 807       = maybeToBool (maybePurelyLocalTyCon tycon)
 808     weird_datacon not_a_datacon_therefore_not_weird = False
 809
 810     weird_tuplecon (TupleConId arity)
 811       = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
 812     weird_tuplecon _ = False
 813 -}
 814 \end{code}
 815
 816 \begin{code}
 817 {-LATER:
 818 idWantsToBeINLINEd :: Id -> Bool
 819
 820 idWantsToBeINLINEd id
 821   = case (getIdUnfolding id) of
 822       IWantToBeINLINEd _ -> True
 823       _ -> False
 824 -}
 825 \end{code}
 826
 827 For @unlocaliseId@: See the brief commentary in
 828 \tr{simplStg/SimplStg.lhs}.
 829
 830 \begin{code}
 831 {-LATER:
 832 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
 833
 834 unlocaliseId mod (Id u ty info (TopLevId fn))
 835   = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
 836
 837 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
 838   = --false?: ASSERT(no_ftvs)
 839     let
 840         full_name = unlocaliseShortName mod u sn
 841     in
 842     Just (Id u ty info (TopLevId full_name))
 843
 844 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
 845   = --false?: on PreludeGlaST: ASSERT(no_ftvs)
 846     let
 847         full_name = unlocaliseShortName mod u sn
 848     in
 849     Just (Id u ty info (TopLevId full_name))
 850
 851 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
 852   = case unlocalise_parent mod u unspec of
 853       Nothing -> Nothing
 854       Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
 855
 856 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
 857   = case unlocalise_parent mod u unwrkr of
 858       Nothing -> Nothing
 859       Just xx -> Just (Id u ty info (WorkerId xx))
 860
 861 unlocaliseId mod (Id u ty info (InstId name))
 862   = Just (Id u ty info (TopLevId full_name))
 863         -- type might be wrong, but it hardly matters
 864         -- at this stage (just before printing C)  ToDo
 865   where
 866     name = getLocalName name
 867     full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
 868
 869 unlocaliseId mod other_id = Nothing
 870
 871 --------------------
 872 -- we have to be Very Careful for workers/specs of
 873 -- local functions!
 874
 875 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
 876   = --false?: ASSERT(no_ftvs)
 877     let
 878         full_name = unlocaliseShortName mod uniq sn
 879     in
 880     Just (Id uniq ty info (TopLevId full_name))
 881
 882 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
 883   = --false?: ASSERT(no_ftvs)
 884     let
 885         full_name = unlocaliseShortName mod uniq sn
 886     in
 887     Just (Id uniq ty info (TopLevId full_name))
 888
 889 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
 890   -- we're OK otherwise
 891 -}
 892 \end{code}
 893
 894 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
 895 `Top-levelish Ids'' cannot have any free type variables, so applying
 896 the type-env cannot have any effect.  (NB: checked in CoreLint?)
 897
 898 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 899 former ``should be'' the usual crunch point.
 900
 901 \begin{code}
 902 {-LATER:
 903 applyTypeEnvToId :: TypeEnv -> Id -> Id
 904
 905 applyTypeEnvToId type_env id@(Id u ty info details)
 906   | idHasNoFreeTyVars id
 907   = id
 908   | otherwise
 909   = apply_to_Id ( \ ty ->
 910         applyTypeEnvToTy type_env ty
 911     ) id
 912 -}
 913 \end{code}
 914
 915 \begin{code}
 916 {-LATER:
 917 apply_to_Id :: (Type -> Type)
 918             -> Id
 919             -> Id
 920
 921 apply_to_Id ty_fn (Id u ty info details)
 922   = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
 923   where
 924     apply_to_details (InstId inst)
 925       = let
 926             new_inst = apply_to_Inst ty_fn inst
 927         in
 928         InstId new_inst
 929
 930     apply_to_details (SpecId unspec ty_maybes no_ftvs)
 931       = let
 932             new_unspec = apply_to_Id ty_fn unspec
 933             new_maybes = map apply_to_maybe ty_maybes
 934         in
 935         SpecId new_unspec new_maybes no_ftvs
 936         -- ToDo: recalc no_ftvs????
 937       where
 938         apply_to_maybe Nothing   = Nothing
 939         apply_to_maybe (Just ty) = Just (ty_fn ty)
 940
 941     apply_to_details (WorkerId unwrkr)
 942       = let
 943             new_unwrkr = apply_to_Id ty_fn unwrkr
 944         in
 945         WorkerId new_unwrkr
 946
 947     apply_to_details other = other
 948 -}
 949 \end{code}
 950
 951 Sadly, I don't think the one using the magic typechecker substitution
 952 can be done with @apply_to_Id@.  Here we go....
 953
 954 Strictness is very important here.  We can't leave behind thunks
 955 with pointers to the substitution: it {\em must} be single-threaded.
 956
 957 \begin{code}
 958 {-LATER:
 959 applySubstToId :: Subst -> Id -> (Subst, Id)
 960
 961 applySubstToId subst id@(Id u ty info details)
 962   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
 963   -- because, in the typechecker, we are still
 964   -- *concocting* the types.
 965   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
 966     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
 967     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
 968     (s4, Id u new_ty new_info new_details) }}}
 969   where
 970     apply_to_details subst _ (InstId inst)
 971       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
 972         (s2, InstId new_inst) }
 973
 974     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
 975       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
 976         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 977         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 978         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
 979       where
 980         apply_to_maybe subst Nothing   = (subst, Nothing)
 981         apply_to_maybe subst (Just ty)
 982           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 983             (s2, Just new_ty) }
 984
 985     apply_to_details subst _ (WorkerId unwrkr)
 986       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
 987         (s2, WorkerId new_unwrkr) }
 988
 989     apply_to_details subst _ other = (subst, other)
 990 -}
 991 \end{code}
 992
 993 \begin{code}
 994 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
 995 getIdNamePieces show_uniqs id
 996   = get (unsafeGenId2Id id)
 997   where
 998   get (Id u _ details _ _)
 999     = case details of
1000       DataConId n _ _ _ _ _ _ ->
1001         case (getOrigName n) of { (mod, name) ->
1002         if fromPrelude mod then [name] else [mod, name] }
1003
1004       TupleConId 0 -> [SLIT("()")]
1005       TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
1006
1007       ImportedId n -> get_fullname_pieces n
1008       PreludeId  n -> get_fullname_pieces n
1009       TopLevId   n -> get_fullname_pieces n
1010
1011       SuperDictSelId c sc ->
1012         case (getOrigName c)    of { (c_mod, c_name) ->
1013         case (getOrigName sc)   of { (sc_mod, sc_name) ->
1014         let
1015             c_bits = if fromPreludeCore c
1016                      then [c_name]
1017                      else [c_mod, c_name]
1018
1019             sc_bits= if fromPreludeCore sc
1020                      then [sc_name]
1021                      else [sc_mod, sc_name]
1022         in
1023         [SLIT("sdsel")] ++ c_bits ++ sc_bits  }}
1024
1025       MethodSelId clas op ->
1026         case (getOrigName clas) of { (c_mod, c_name) ->
1027         case (getClassOpString op)      of { op_name ->
1028         if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
1029         } }
1030
1031       DefaultMethodId clas op _ ->
1032         case (getOrigName clas)         of { (c_mod, c_name) ->
1033         case (getClassOpString op)      of { op_name ->
1034         if fromPreludeCore clas
1035         then [SLIT("defm"), op_name]
1036         else [SLIT("defm"), c_mod, c_name, op_name] }}
1037
1038       DictFunId c ty _ _ ->
1039         case (getOrigName c)        of { (c_mod, c_name) ->
1040         let
1041             c_bits = if fromPreludeCore c
1042                      then [c_name]
1043                      else [c_mod, c_name]
1044
1045             ty_bits = getTypeString ty
1046         in
1047         [SLIT("dfun")] ++ c_bits ++ ty_bits }
1048
1049
1050       ConstMethodId c ty o _ _ ->
1051         case (getOrigName c)        of { (c_mod, c_name) ->
1052         case (getTypeString ty)     of { ty_bits ->
1053         case (getClassOpString o)   of { o_name ->
1054         case (if fromPreludeCore c
1055                 then []
1056                 else [c_mod, c_name])   of { c_bits ->
1057         [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1058
1059       -- if the unspecialised equiv is "top-level",
1060       -- the name must be concocted from its name and the
1061       -- names of the types to which specialised...
1062
1063       SpecId unspec ty_maybes _ ->
1064         get unspec ++ (if not (toplevelishId unspec)
1065                        then [showUnique u]
1066                        else concat (map typeMaybeString ty_maybes))
1067
1068       WorkerId unwrkr ->
1069         get unwrkr ++ (if not (toplevelishId unwrkr)
1070                        then [showUnique u]
1071                        else [SLIT("wrk")])
1072
1073       LocalId      n _   -> let local = getLocalName n in
1074                             if show_uniqs then [local, showUnique u] else [local]
1075       InstId       n     -> [getLocalName n, showUnique u]
1076       SysLocalId   n _   -> [getLocalName n, showUnique u]
1077       SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1078
1079 get_fullname_pieces :: FullName -> [FAST_STRING]
1080 get_fullname_pieces n
1081   = BIND (getOrigName n) _TO_ (mod, name) ->
1082     if fromPrelude mod
1083     then [name]
1084     else [mod, name]
1085     BEND
1086 \end{code}
1087
1088 %************************************************************************
1089 %*                                                                      *
1090 \subsection[Id-type-funs]{Type-related @Id@ functions}
1091 %*                                                                      *
1092 %************************************************************************
1093
1094 \begin{code}
1095 idType :: GenId ty -> ty
1096
1097 idType (Id _ ty _ _ _) = ty
1098 \end{code}
1099
1100 \begin{code}
1101 {-LATER:
1102 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1103
1104 getMentionedTyConsAndClassesFromId id
1105  = getMentionedTyConsAndClassesFromType (idType id)
1106 -}
1107 \end{code}
1108
1109 \begin{code}
1110 --getIdPrimRep i = primRepFromType (idType i)
1111 \end{code}
1112
1113 \begin{code}
1114 {-LATER:
1115 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1116 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1117 getInstIdModule other = panic "Id:getInstIdModule"
1118 -}
1119 \end{code}
1120
1121 %************************************************************************
1122 %*                                                                      *
1123 \subsection[Id-overloading]{Functions related to overloading}
1124 %*                                                                      *
1125 %************************************************************************
1126
1127 \begin{code}
1128 mkSuperDictSelId  u c sc     ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1129 mkMethodSelId       u c op     ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1130 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1131
1132 mkDictFunId u c ity full_ty from_here modname info
1133   = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
1134
1135 mkConstMethodId u c op ity full_ty from_here modname info
1136   = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
1137
1138 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1139
1140 mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
1141
1142 {-LATER:
1143 getConstMethodId clas op ty
1144   = -- constant-method info is hidden in the IdInfo of
1145     -- the class-op id (as mentioned up above).
1146     let
1147         sel_id = getMethodSelId clas op
1148     in
1149     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1150       Just xx -> xx
1151       Nothing -> error (ppShow 80 (ppAboves [
1152         ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
1153                ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1154                ppr PprDebug sel_id],
1155         ppStr "(This can arise if an interface pragma refers to an instance",
1156         ppStr "but there is no imported interface which *defines* that instance.",
1157         ppStr "The info above, however ugly, should indicate what else you need to import."
1158         ]))
1159 -}
1160 \end{code}
1161
1162 %************************************************************************
1163 %*                                                                      *
1164 \subsection[local-funs]{@LocalId@-related functions}
1165 %*                                                                      *
1166 %************************************************************************
1167
1168 \begin{code}
1169 mkImported    u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
1170 mkPreludeId   u n ty info = Id u ty (PreludeId  n) NoPragmaInfo info
1171
1172 {-LATER:
1173 updateIdType :: Id -> Type -> Id
1174 updateIdType (Id u _ info details) ty = Id u ty info details
1175 -}
1176 \end{code}
1177
1178 \begin{code}
1179 no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy ty)
1180
1181 -- SysLocal: for an Id being created by the compiler out of thin air...
1182 -- UserLocal: an Id with a name the user might recognize...
1183 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> ty -> SrcLoc -> GenId ty
1184
1185 mkSysLocal str uniq ty loc
1186   = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1187
1188 mkUserLocal str uniq ty loc
1189   = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1190
1191 -- mkUserId builds a local or top-level Id, depending on the name given
1192 mkUserId :: Name -> ty -> PragmaInfo -> GenId ty
1193 mkUserId (Short uniq short) ty pragma_info
1194   = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
1195 mkUserId (ValName uniq full) ty pragma_info
1196   = Id uniq ty
1197         (if isLocallyDefined full then TopLevId full else ImportedId full)
1198         pragma_info noIdInfo
1199 \end{code}
1200
1201
1202 \begin{code}
1203 {-LATER:
1204
1205 -- for a SpecPragmaId being created by the compiler out of thin air...
1206 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1207 mkSpecPragmaId str uniq ty specid loc
1208   = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1209
1210 -- for new SpecId
1211 mkSpecId u unspec ty_maybes ty info
1212   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1213     Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1214
1215 -- Specialised version of constructor: only used in STG and code generation
1216 -- Note: The specialsied Id has the same unique as the unspeced Id
1217
1218 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1219   = ASSERT(isDataCon unspec)
1220     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1221     Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1222   where
1223     new_ty = specialiseTy ty ty_maybes 0
1224
1225     -- pprTrace "SameSpecCon:Unique:"
1226     --          (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
1227
1228 localiseId :: Id -> Id
1229 localiseId id@(Id u ty info details)
1230   = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1231   where
1232     name = getOccurrenceName id
1233     loc  = getSrcLoc id
1234
1235 -- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
1236 -- ToDo: it does??? WDP
1237 mkIdWithNewUniq :: Id -> Unique -> Id
1238
1239 mkIdWithNewUniq (Id _ ty info details) uniq
1240   = Id uniq ty info new_details
1241 -}
1242 \end{code}
1243
1244 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
1245 @Uniques@, but that's OK because the templates are supposed to be
1246 instantiated before use.
1247 \begin{code}
1248 {-LATER:
1249 mkTemplateLocals :: [Type] -> [Id]
1250 mkTemplateLocals tys
1251   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
1252             (getBuiltinUniques (length tys))
1253             tys
1254 -}
1255 \end{code}
1256
1257 \begin{code}
1258 getIdInfo     :: GenId ty -> IdInfo
1259 getPragmaInfo :: GenId ty -> PragmaInfo
1260
1261 getIdInfo     (Id _ _ _ _ info) = info
1262 getPragmaInfo (Id _ _ _ info _) = info
1263
1264 {-LATER:
1265 replaceIdInfo :: Id -> IdInfo -> Id
1266
1267 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1268
1269 selectIdInfoForSpecId :: Id -> IdInfo
1270 selectIdInfoForSpecId unspec
1271   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1272     noIdInfo `addInfo_UF` getIdUnfolding unspec
1273 -}
1274 \end{code}
1275
1276 %************************************************************************
1277 %*                                                                      *
1278 \subsection[Id-arities]{Arity-related functions}
1279 %*                                                                      *
1280 %************************************************************************
1281
1282 For locally-defined Ids, the code generator maintains its own notion
1283 of their arities; so it should not be asking...  (but other things
1284 besides the code-generator need arity info!)
1285
1286 \begin{code}
1287 getIdArity :: Id -> ArityInfo
1288 getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
1289
1290 getDataConArity :: DataCon -> Int
1291 getDataConArity id@(Id _ _ _ _ id_info)
1292   = ASSERT(isDataCon id)
1293     case (arityMaybe (getInfo id_info)) of
1294       Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
1295       Just  i -> i
1296
1297 addIdArity :: Id -> Int -> Id
1298 addIdArity (Id u ty details pinfo info) arity
1299   = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1300 \end{code}
1301
1302 %************************************************************************
1303 %*                                                                      *
1304 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1305 %*                                                                      *
1306 %************************************************************************
1307
1308 \begin{code}
1309 mkDataCon :: Unique{-DataConKey-}
1310           -> FullName
1311           -> [StrictnessMark]
1312           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1313 --ToDo:   -> SpecEnv
1314           -> Id
1315   -- can get the tag and all the pieces of the type from the Type
1316
1317 mkDataCon k n stricts tvs ctxt args_tys tycon
1318   = ASSERT(length stricts == length args_tys)
1319     data_con
1320   where
1321     -- NB: data_con self-recursion; should be OK as tags are not
1322     -- looked at until late in the game.
1323     data_con
1324       = Id k
1325            type_of_constructor
1326            (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
1327            NoPragmaInfo
1328            datacon_info
1329
1330     data_con_tag    = position_within fIRST_TAG data_con_family
1331
1332     data_con_family = getTyConDataCons tycon
1333
1334     position_within :: Int -> [Id] -> Int
1335
1336     position_within acc (c:cs)
1337       = if c == data_con then acc else position_within (acc+1) cs
1338 #ifdef DEBUG
1339     position_within acc []
1340       = panic "mkDataCon: con not found in family"
1341 #endif
1342
1343     type_of_constructor
1344       = mkSigmaTy tvs ctxt
1345         (mkFunTys args_tys (applyTyCon tycon (map mkTyVarTy tvs)))
1346
1347     datacon_info = noIdInfo `addInfo_UF` unfolding
1348                             `addInfo` mkArityInfo arity
1349 --ToDo:                     `addInfo` specenv
1350
1351     arity = length args_tys
1352
1353     unfolding
1354       = noInfo_UF
1355 {- LATER:
1356       = -- if arity == 0
1357         -- then noIdInfo
1358         -- else -- do some business...
1359         let
1360             (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1361             tyvar_tys = map mkTyVarTy tyvars
1362         in
1363         BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1364
1365         mkUnfolding EssentialUnfolding -- for data constructors
1366                     (mkLam tyvars (dict_vars ++ vars) plain_Con)
1367         BEND
1368
1369     mk_uf_bits tvs ctxt arg_tys tycon
1370       = let
1371             (inst_env, tyvars, tyvar_tys)
1372               = instantiateTyVarTemplates tvs
1373                                           (map getItsUnique tvs)
1374         in
1375             -- the "context" and "arg_tys" have TyVarTemplates in them, so
1376             -- we instantiate those types to have the right TyVars in them
1377             -- instead.
1378         BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1379                                                         _TO_ inst_dict_tys ->
1380         BIND (map (instantiateTauTy inst_env) arg_tys)  _TO_ inst_arg_tys ->
1381
1382             -- We can only have **ONE** call to mkTemplateLocals here;
1383             -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1384             -- (Mega-Sigh) [ToDo]
1385         BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1386
1387         BIND (splitAt (length ctxt) all_vars)   _TO_ (dict_vars, vars) ->
1388
1389         (tyvars, dict_vars, vars)
1390         BEND BEND BEND BEND
1391       where
1392         -- these are really dubious Types, but they are only to make the
1393         -- binders for the lambdas for tossed-away dicts.
1394         ctxt_ty (clas, ty) = mkDictTy clas ty
1395 -}
1396 \end{code}
1397
1398 \begin{code}
1399 mkTupleCon :: Arity -> Id
1400
1401 mkTupleCon arity
1402   = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
1403   where
1404     unique      = mkTupleDataConUnique arity
1405     ty          = mkSigmaTy tyvars []
1406                    (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1407     tycon       = mkTupleTyCon arity
1408     tyvars      = take arity alphaTyVars
1409     tyvar_tys   = map mkTyVarTy tyvars
1410
1411     tuplecon_info
1412       = noIdInfo `addInfo_UF` unfolding
1413                  `addInfo` mkArityInfo arity
1414 --LATER:?        `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1415
1416     unfolding
1417       = noInfo_UF
1418 {- LATER:
1419       = -- if arity == 0
1420         -- then noIdInfo
1421         -- else -- do some business...
1422         let
1423             (tyvars, dict_vars, vars) = mk_uf_bits arity
1424             tyvar_tys = map mkTyVarTy tyvars
1425         in
1426         BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1427
1428         mkUnfolding
1429             EssentialUnfolding    -- data constructors
1430             (mkLam tyvars (dict_vars ++ vars) plain_Con)
1431         BEND
1432
1433     mk_uf_bits arity
1434       = BIND (mkTemplateLocals tyvar_tys)                _TO_ vars ->
1435         (tyvars, [], vars)
1436         BEND
1437       where
1438         tyvar_tmpls     = take arity alphaTyVars
1439         (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
1440 -}
1441
1442 fIRST_TAG :: ConTag
1443 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1444 \end{code}
1445
1446 \begin{code}
1447 getDataConTag :: DataCon -> ConTag      -- will panic if not a DataCon
1448 getDataConTag   (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
1449 getDataConTag   (Id _ _ (TupleConId _) _ _)              = fIRST_TAG
1450 getDataConTag   (Id _ _ (SpecId unspec _ _) _ _)         = getDataConTag unspec
1451
1452 getDataConTyCon :: DataCon -> TyCon     -- will panic if not a DataCon
1453 getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1454 getDataConTyCon (Id _ _ (TupleConId a) _ _)                = mkTupleTyCon a
1455
1456 getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1457                                         -- will panic if not a DataCon
1458
1459 getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1460   = (tyvars, theta_ty, arg_tys, tycon)
1461
1462 getDataConSig (Id _ _ (TupleConId arity) _ _)
1463   = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1464   where
1465     tyvars      = take arity alphaTyVars
1466     tyvar_tys   = map mkTyVarTy tyvars
1467 \end{code}
1468
1469 {- LATER
1470 getDataConTyCon (Id _ _ _ (SpecId unspec tys _))
1471   = mkSpecTyCon (getDataConTyCon unspec) tys
1472
1473 getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
1474   = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
1475   where
1476     (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
1477
1478     ty_env = tyvars `zip` ty_maybes
1479
1480     spec_tyvars = foldr nothing_tyvars [] ty_env
1481     nothing_tyvars (tyvar, Nothing) l = tyvar : l
1482     nothing_tyvars (tyvar, Just ty) l = l
1483
1484     spec_env = foldr just_env [] ty_env
1485     just_env (tyvar, Nothing) l = l
1486     just_env (tyvar, Just ty) l = (tyvar, ty) : l
1487     spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
1488
1489     spec_theta_ty = if null theta_ty then []
1490                     else panic "getDataConSig:ThetaTy:SpecDataCon"
1491     spec_tycon    = mkSpecTyCon tycon ty_maybes
1492 -}
1493 \end{code}
1494
1495 \begin{pseudocode}
1496 @getInstantiatedDataConSig@ takes a constructor and some types to which
1497 it is applied; it returns its signature instantiated to these types.
1498
1499 \begin{code}
1500 getInstantiatedDataConSig ::
1501            DataCon      -- The data constructor
1502                         --   Not a specialised data constructor
1503         -> [TauType]    -- Types to which applied
1504                         --   Must be fully applied i.e. contain all types of tycon
1505         -> ([TauType],  -- Types of dict args
1506             [TauType],  -- Types of regular args
1507             TauType     -- Type of result
1508            )
1509
1510 getInstantiatedDataConSig data_con inst_tys
1511   = ASSERT(isDataCon data_con)
1512     let
1513         (tvs, theta, arg_tys, tycon) = getDataConSig data_con
1514
1515         inst_env = ASSERT(length tvs == length inst_tys)
1516                    tvs `zip` inst_tys
1517
1518         theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1519         cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
1520         result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
1521     in
1522     -- Are the first/third results ever used?
1523     (theta_tys, cmpnt_tys, result_ty)
1524 \end{code}
1525
1526 Data type declarations are of the form:
1527 \begin{verbatim}
1528 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1529 \end{verbatim}
1530 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1531 @C1 x y z@, we want a function binding:
1532 \begin{verbatim}
1533 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1534 \end{verbatim}
1535 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1536 2nd-order polymorphic lambda calculus with explicit types.
1537
1538 %************************************************************************
1539 %*                                                                      *
1540 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1541 %*                                                                      *
1542 %************************************************************************
1543
1544 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1545 and generates an @UnfoldingDetails@ for its unfolding.  The @Ids@ and
1546 @TyVars@ don't really have to be new, because we are only producing a
1547 template.
1548
1549 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1550 --WDP)?
1551
1552 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1553 EXPORTED.  It just returns the binders (@TyVars@ and @Ids@) [in the
1554 example above: a, b, and x, y, z], which is enough (in the important
1555 \tr{DsExpr} case).  (The middle set of @Ids@ is binders for any
1556 dictionaries, in the even of an overloaded data-constructor---none at
1557 present.)
1558
1559 \begin{code}
1560 getIdUnfolding :: Id -> UnfoldingDetails
1561
1562 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1563
1564 {-LATER:
1565 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1566 addIdUnfolding id@(Id u ty info details) unfold_details
1567   = ASSERT(
1568         case (isLocallyDefined id, unfold_details) of
1569         (_,     NoUnfoldingDetails) -> True
1570         (True,  IWantToBeINLINEd _) -> True
1571         (False, IWantToBeINLINEd _) -> False -- v bad
1572         (False, _)                  -> True
1573         _                           -> False -- v bad
1574     )
1575     Id u ty (info `addInfo_UF` unfold_details) details
1576 -}
1577 \end{code}
1578
1579 In generating selector functions (take a dictionary, give back one
1580 component...), we need to what out for the nothing-to-select cases (in
1581 which case the ``selector'' is just an identity function):
1582 \begin{verbatim}
1583 class Eq a => Foo a { }     # the superdict selector for "Eq"
1584
1585 class Foo a { op :: Complex b => c -> b -> a }
1586                             # the method selector for "op";
1587                             # note local polymorphism...
1588 \end{verbatim}
1589
1590 %************************************************************************
1591 %*                                                                      *
1592 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1593 %*                                                                      *
1594 %************************************************************************
1595
1596 \begin{code}
1597 getIdDemandInfo :: Id -> DemandInfo
1598 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1599
1600 addIdDemandInfo :: Id -> DemandInfo -> Id
1601 addIdDemandInfo (Id u ty details prags info) demand_info
1602   = Id u ty details prags (info `addInfo` demand_info)
1603 \end{code}
1604
1605 \begin{code}
1606 getIdUpdateInfo :: Id -> UpdateInfo
1607 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1608
1609 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1610 addIdUpdateInfo (Id u ty details prags info) upd_info
1611   = Id u ty details prags (info `addInfo` upd_info)
1612 \end{code}
1613
1614 \begin{code}
1615 {- LATER:
1616 getIdArgUsageInfo :: Id -> ArgUsageInfo
1617 getIdArgUsageInfo (Id u ty info details) = getInfo info
1618
1619 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1620 addIdArgUsageInfo (Id u ty info details) au_info
1621   = Id u ty (info `addInfo` au_info) details
1622 -}
1623 \end{code}
1624
1625 \begin{code}
1626 {- LATER:
1627 getIdFBTypeInfo :: Id -> FBTypeInfo
1628 getIdFBTypeInfo (Id u ty info details) = getInfo info
1629
1630 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1631 addIdFBTypeInfo (Id u ty info details) upd_info
1632   = Id u ty (info `addInfo` upd_info) details
1633 -}
1634 \end{code}
1635
1636 \begin{code}
1637 {- LATER:
1638 getIdSpecialisation :: Id -> SpecEnv
1639 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1640
1641 addIdSpecialisation :: Id -> SpecEnv -> Id
1642 addIdSpecialisation (Id u ty details prags info) spec_info
1643   = Id u ty details prags (info `addInfo` spec_info)
1644 -}
1645 \end{code}
1646
1647 Strictness: we snaffle the info out of the IdInfo.
1648
1649 \begin{code}
1650 getIdStrictness :: Id -> StrictnessInfo
1651
1652 getIdStrictness (Id _ _ _ _ info) = getInfo info
1653
1654 addIdStrictness :: Id -> StrictnessInfo -> Id
1655
1656 addIdStrictness (Id u ty details prags info) strict_info
1657   = Id u ty details prags (info `addInfo` strict_info)
1658 \end{code}
1659
1660 %************************************************************************
1661 %*                                                                      *
1662 \subsection[Id-comparison]{Comparison functions for @Id@s}
1663 %*                                                                      *
1664 %************************************************************************
1665
1666 Comparison: equality and ordering---this stuff gets {\em hammered}.
1667
1668 \begin{code}
1669 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1670 -- short and very sweet
1671 \end{code}
1672
1673 \begin{code}
1674 instance Ord3 (GenId ty) where
1675     cmp = cmpId
1676
1677 instance Eq (GenId ty) where
1678     a == b = case cmpId a b of { EQ_ -> True;  _ -> False }
1679     a /= b = case cmpId a b of { EQ_ -> False; _ -> True  }
1680
1681 instance Ord (GenId ty) where
1682     a <= b = case cmpId a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1683     a <  b = case cmpId a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1684     a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1685     a >  b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1686     _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1687 \end{code}
1688
1689 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1690 account when comparing two data constructors. We need to do this
1691 because a specialised data constructor has the same Unique as its
1692 unspecialised counterpart.
1693
1694 \begin{code}
1695 {-LATER:
1696 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1697
1698 cmpId_withSpecDataCon id1 id2
1699   | eq_ids && isDataCon id1 && isDataCon id2
1700   = cmpEqDataCon id1 id2
1701
1702   | otherwise
1703   = cmp_ids
1704   where
1705     cmp_ids = cmpId id1 id2
1706     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1707
1708 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
1709   = cmpUniTypeMaybeList mtys1 mtys2
1710
1711 cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
1712   = LT_
1713
1714 cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
1715   = GT_
1716
1717 cmpEqDataCon unspec1 unspec2
1718   = EQ_
1719 -}
1720 \end{code}
1721
1722 %************************************************************************
1723 %*                                                                      *
1724 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1725 %*                                                                      *
1726 %************************************************************************
1727
1728 \begin{code}
1729 instance Outputable ty => Outputable (GenId ty) where
1730     ppr sty id = pprId sty id
1731
1732 showId :: PprStyle -> Id -> String
1733 showId sty id = ppShow 80 (pprId sty id)
1734
1735 -- [used below]
1736 -- for DictFuns (instances) and const methods (instance code bits we
1737 -- can call directly): exported (a) if *either* the class or
1738 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1739 -- class and tycon are from PreludeCore [non-std, but convenient]
1740 -- *and* the thing was defined in this module.
1741
1742 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1743
1744 instance_export_flag clas inst_ty from_here
1745   = panic "Id:instance_export_flag"
1746 {-LATER
1747   = if instanceIsExported clas inst_ty from_here
1748     then ExportAll
1749     else NotExported
1750 -}
1751 \end{code}
1752
1753 Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
1754 PreludeCore''?  True if the outermost TyCon is fromPreludeCore.
1755 \begin{code}
1756 is_prelude_core_ty :: Type -> Bool
1757
1758 is_prelude_core_ty inst_ty
1759   = panic "Id.is_prelude_core_ty"
1760 {- LATER
1761   = case maybeDataTyCon inst_ty of
1762       Just (tycon,_,_) -> fromPreludeCore tycon
1763       Nothing          -> panic "Id: is_prelude_core_ty"
1764 -}
1765 \end{code}
1766
1767 Default printing code (not used for interfaces):
1768 \begin{code}
1769 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1770
1771 pprId other_sty id
1772   = let
1773         pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1774
1775         for_code = panic "pprId: for code"
1776         {-  = let
1777                 pieces_to_print -- maybe use Unique only
1778                   = if isSysLocalId id then tail pieces else pieces
1779             in
1780             ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1781         -}
1782     in
1783     case other_sty of
1784       PprForC         -> for_code
1785       PprForAsm _ _   -> for_code
1786       PprInterface    -> ppPStr occur_name
1787       PprForUser      -> ppPStr occur_name
1788       PprUnfolding    -> qualified_name pieces
1789       PprDebug        -> qualified_name pieces
1790       PprShowAll      -> ppBesides [qualified_name pieces,
1791                             (ppCat [pp_uniq id,
1792                                     ppPStr SLIT("{-"),
1793                                     ppr other_sty (idType id),
1794                                     ppIdInfo other_sty (unsafeGenId2Id id) True
1795                                              (\x->x) nullIdEnv (getIdInfo id),
1796                                     ppPStr SLIT("-}") ])]
1797   where
1798     occur_name = getOccurrenceName id _APPEND_
1799                  ( _PK_ (if not (isSysLocalId id)
1800                          then ""
1801                          else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
1802
1803     qualified_name pieces
1804       = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1805
1806     pp_uniq (Id _ _ (PreludeId _) _ _)             = ppNil -- no uniq to add
1807     pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
1808     pp_uniq (Id _ _ (TupleConId _) _ _)            = ppNil
1809     pp_uniq (Id _ _ (LocalId _ _) _ _)             = ppNil -- uniq printed elsewhere
1810     pp_uniq (Id _ _ (SysLocalId _ _) _ _)          = ppNil
1811     pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _)      = ppNil
1812     pp_uniq (Id _ _ (InstId _) _ _)                = ppNil
1813     pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
1814
1815     -- print PprDebug Ids with # afterwards if they are of primitive type.
1816     pp_ubxd pretty = pretty
1817
1818 {- LATER: applying isPrimType restricts type
1819     pp_ubxd pretty = if isPrimType (idType id)
1820                      then ppBeside pretty (ppChar '#')
1821                      else pretty
1822 -}
1823
1824 \end{code}
1825
1826 \begin{code}
1827 instance NamedThing (GenId ty) where
1828     getExportFlag (Id _ _ details _ _)
1829       = get details
1830       where
1831         get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
1832         get (TupleConId _)          = NotExported
1833         get (ImportedId  n)         = getExportFlag n
1834         get (PreludeId   n)         = getExportFlag n
1835         get (TopLevId    n)         = getExportFlag n
1836         get (SuperDictSelId c _)    = getExportFlag c
1837         get (MethodSelId  c _)      = getExportFlag c
1838         get (DefaultMethodId c _ _) = getExportFlag c
1839         get (DictFunId  c ty from_here _) = instance_export_flag c ty from_here
1840         get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
1841         get (SpecId unspec _ _)     = getExportFlag unspec
1842         get (WorkerId unwrkr)       = getExportFlag unwrkr
1843         get (InstId _)              = NotExported
1844         get (LocalId      _ _)      = NotExported
1845         get (SysLocalId   _ _)      = NotExported
1846         get (SpecPragmaId _ _ _)    = NotExported
1847
1848     isLocallyDefined this_id@(Id _ _ details _ _)
1849       = get details
1850       where
1851         get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
1852         get (TupleConId _)          = False
1853         get (ImportedId _)          = False
1854         get (PreludeId  _)          = False
1855         get (TopLevId   n)          = isLocallyDefined n
1856         get (SuperDictSelId c _)    = isLocallyDefined c
1857         get (MethodSelId c _)       = isLocallyDefined c
1858         get (DefaultMethodId c _ _) = isLocallyDefined c
1859         get (DictFunId c tyc from_here _) = from_here
1860             -- For DictFunId and ConstMethodId things, you really have to
1861             -- know whether it came from an imported instance or one
1862             -- really here; no matter where the tycon and class came from.
1863
1864         get (ConstMethodId c tyc _ from_here _) = from_here
1865         get (SpecId unspec _ _)     = isLocallyDefined unspec
1866         get (WorkerId unwrkr)       = isLocallyDefined unwrkr
1867         get (InstId  _)             = True
1868         get (LocalId      _ _)      = True
1869         get (SysLocalId   _ _)      = True
1870         get (SpecPragmaId _ _ _)    = True
1871
1872     getOrigName this_id@(Id u _ details _ _)
1873       = get details
1874       where
1875         get (DataConId n _ _ _ _ _ _) =  getOrigName n
1876         get (TupleConId 0)      = (pRELUDE_BUILTIN, SLIT("()"))
1877         get (TupleConId a)      = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
1878         get (ImportedId   n)    = getOrigName n
1879         get (PreludeId    n)    = getOrigName n
1880         get (TopLevId     n)    = getOrigName n
1881
1882         get (MethodSelId c op)  = case (getOrigName c) of -- ToDo; better ???
1883                                     (mod, _) -> (mod, getClassOpString op)
1884
1885 {- LATER:
1886         get (SpecId unspec ty_maybes _)
1887           = BIND getOrigName unspec           _TO_ (mod, unspec_nm) ->
1888             BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1889             (mod,
1890              unspec_nm _APPEND_
1891                 (if not (toplevelishId unspec)
1892                  then showUnique u
1893                  else tys_suffix)
1894             )
1895             BEND BEND
1896
1897         get (WorkerId unwrkr)
1898           = BIND getOrigName unwrkr     _TO_ (mod, unwrkr_nm) ->
1899             (mod,
1900              unwrkr_nm _APPEND_
1901                 (if not (toplevelishId unwrkr)
1902                  then showUnique u
1903                  else SLIT(".wrk"))
1904             )
1905             BEND
1906 -}
1907
1908         get (InstId       n)    = (panic "NamedThing.Id.getOrigName (LocalId)",
1909                                    getLocalName n)
1910         get (LocalId      n _)  = (panic "NamedThing.Id.getOrigName (LocalId)",
1911                                    getLocalName n)
1912         get (SysLocalId   n _)  = (panic "NamedThing.Id.getOrigName (SysLocal)",
1913                                    getLocalName n)
1914         get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
1915                                    getLocalName n)
1916
1917         get other_details
1918             -- the remaining internally-generated flavours of
1919             -- Ids really do not have meaningful "original name" stuff,
1920             -- but we need to make up something (usually for debugging output)
1921
1922           = BIND (getIdNamePieces True this_id)  _TO_ (piece1:pieces) ->
1923             BIND [ _CONS_ '.' p | p <- pieces ]  _TO_ dotted_pieces ->
1924             (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1925             BEND BEND
1926
1927     getOccurrenceName this_id@(Id _ _ details _ _)
1928       = get details
1929       where
1930         get (DataConId  n _ _ _ _ _ _) = getOccurrenceName n
1931         get (TupleConId 0)      = SLIT("()")
1932         get (TupleConId a)      = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
1933         get (ImportedId  n)     = getOccurrenceName n
1934         get (PreludeId   n)     = getOccurrenceName n
1935         get (TopLevId    n)     = getOccurrenceName n
1936         get (MethodSelId _ op)  = getClassOpString op
1937         get _                   = snd (getOrigName this_id)
1938
1939     getInformingModules id = panic "getInformingModule:Id"
1940
1941     getSrcLoc (Id _ _ details _ id_info)
1942       = get details
1943       where
1944         get (DataConId  n _ _ _ _ _ _) = getSrcLoc n
1945         get (TupleConId _)      = mkBuiltinSrcLoc
1946         get (ImportedId  n)     = getSrcLoc n
1947         get (PreludeId   n)     = getSrcLoc n
1948         get (TopLevId    n)     = getSrcLoc n
1949         get (SuperDictSelId c _)= getSrcLoc c
1950         get (MethodSelId c _)   = getSrcLoc c
1951         get (SpecId unspec _ _) = getSrcLoc unspec
1952         get (WorkerId unwrkr)   = getSrcLoc unwrkr
1953         get (InstId       n)    = getSrcLoc n
1954         get (LocalId      n _)  = getSrcLoc n
1955         get (SysLocalId   n _)  = getSrcLoc n
1956         get (SpecPragmaId n _ _)= getSrcLoc n
1957         -- well, try the IdInfo
1958         get something_else = getSrcLocIdInfo id_info
1959
1960     getItsUnique (Id u _ _ _ _) = u
1961
1962     fromPreludeCore (Id _ _ details _ _)
1963       = get details
1964       where
1965         get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
1966         get (TupleConId _)          = True
1967         get (ImportedId  n)         = fromPreludeCore n
1968         get (PreludeId   n)         = fromPreludeCore n
1969         get (TopLevId    n)         = fromPreludeCore n
1970         get (SuperDictSelId c _)    = fromPreludeCore c
1971         get (MethodSelId c _)       = fromPreludeCore c
1972         get (DefaultMethodId c _ _) = fromPreludeCore c
1973         get (DictFunId  c t _ _)    = fromPreludeCore c && is_prelude_core_ty t
1974         get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
1975         get (SpecId unspec _ _)     = fromPreludeCore unspec
1976         get (WorkerId unwrkr)       = fromPreludeCore unwrkr
1977         get (InstId       _)        = False
1978         get (LocalId      _ _)      = False
1979         get (SysLocalId   _ _)      = False
1980         get (SpecPragmaId _ _ _)    = False
1981 \end{code}
1982
1983 Reason for @getItsUnique@: The code generator doesn't carry a
1984 @UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
1985 given to it.
1986
1987 %************************************************************************
1988 %*                                                                      *
1989 \subsection{@IdEnv@s and @IdSet@s}
1990 %*                                                                      *
1991 %************************************************************************
1992
1993 \begin{code}
1994 type IdEnv elt = UniqFM elt
1995
1996 nullIdEnv         :: IdEnv a
1997
1998 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1999 unitIdEnv         :: GenId ty -> a -> IdEnv a
2000 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
2001 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
2002 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
2003
2004 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
2005 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
2006 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
2007 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
2008 modifyIdEnv       :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
2009 rngIdEnv          :: IdEnv a -> [a]
2010
2011 isNullIdEnv       :: IdEnv a -> Bool
2012 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
2013 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
2014 \end{code}
2015
2016 \begin{code}
2017 addOneToIdEnv    = addToUFM
2018 combineIdEnvs    = plusUFM_C
2019 delManyFromIdEnv = delListFromUFM
2020 delOneFromIdEnv  = delFromUFM
2021 growIdEnv        = plusUFM
2022 lookupIdEnv      = lookupUFM
2023 mapIdEnv         = mapUFM
2024 mkIdEnv          = listToUFM
2025 nullIdEnv        = emptyUFM
2026 rngIdEnv         = eltsUFM
2027 unitIdEnv        = singletonUFM
2028
2029 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
2030 isNullIdEnv       env       = sizeUFM env == 0
2031 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
2032
2033 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
2034 -- modify function, and put it back.
2035
2036 modifyIdEnv env mangle_fn key
2037   = case (lookupIdEnv env key) of
2038       Nothing -> env
2039       Just xx -> addOneToIdEnv env key (mangle_fn xx)
2040 \end{code}
2041
2042 \begin{code}
2043 type GenIdSet ty = UniqSet (GenId ty)
2044 type IdSet       = UniqSet (GenId Type)
2045 \end{code}