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