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