ghc/compiler/basicTypes/Id.lhs

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