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