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         -- TYPES
  11         GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
  12         SYN_IE(Id), IdDetails,
  13         StrictnessMark(..),
  14         SYN_IE(ConTag), fIRST_TAG,
  15         SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
  16
  17         -- CONSTRUCTION
  18         mkConstMethodId,
  19         mkDataCon,
  20         mkDefaultMethodId,
  21         mkDictFunId,
  22         mkIdWithNewUniq,
  23         mkImported,
  24         mkInstId,
  25         mkMethodSelId,
  26         mkRecordSelId,
  27         mkSuperDictSelId,
  28         mkSysLocal,
  29         mkTemplateLocals,
  30         mkTupleCon,
  31         mkUserId,
  32         mkUserLocal,
  33         mkWorkerId,
  34         mkPrimitiveId,
  35         setIdVisibility,
  36
  37         -- DESTRUCTION (excluding pragmatic info)
  38         idPrimRep,
  39         idType,
  40         idUnique,
  41
  42         dataConRepType,
  43         dataConArgTys,
  44         dataConArity,
  45         dataConNumFields,
  46         dataConFieldLabels,
  47         dataConRawArgTys,
  48         dataConSig,
  49         dataConStrictMarks,
  50         dataConTag,
  51         dataConTyCon,
  52
  53         recordSelectorFieldLabel,
  54
  55         -- PREDICATES
  56         wantIdSigInIface,
  57         cmpEqDataCon,
  58         cmpId,
  59         cmpId_withSpecDataCon,
  60         externallyVisibleId,
  61         idHasNoFreeTyVars,
  62         idWantsToBeINLINEd,
  63         idMustBeINLINEd,
  64         isBottomingId,
  65         isConstMethodId,
  66         isConstMethodId_maybe,
  67         isDataCon,
  68         isDefaultMethodId,
  69         isDefaultMethodId_maybe,
  70         isDictFunId,
  71         isImportedId,
  72         isRecordSelector,
  73         isMethodSelId_maybe,
  74         isNullaryDataCon,
  75         isSpecPragmaId,
  76         isSuperDictSelId_maybe,
  77         isPrimitiveId_maybe,
  78         isSysLocalId,
  79         isTupleCon,
  80         isWorkerId,
  81         isWrapperId,
  82         toplevelishId,
  83         unfoldingUnfriendlyId,
  84
  85         -- SUBSTITUTION
  86         applyTypeEnvToId,
  87         apply_to_Id,
  88
  89         -- PRINTING and RENUMBERING
  90         addId,
  91         nmbrDataCon,
  92         nmbrId,
  93         pprId,
  94         showId,
  95
  96         -- Specialialisation
  97         getIdSpecialisation,
  98         addIdSpecialisation,
  99
 100         -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
 101         addIdUnfolding,
 102         addIdArity,
 103         addIdDemandInfo,
 104         addIdStrictness,
 105         addIdUpdateInfo,
 106         getIdArity,
 107         getIdDemandInfo,
 108         getIdInfo,
 109         getIdStrictness,
 110         getIdUnfolding,
 111         getIdUpdateInfo,
 112         getPragmaInfo,
 113         replaceIdInfo,
 114         addInlinePragma,
 115
 116         -- IdEnvs AND IdSets
 117         SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
 118         addOneToIdEnv,
 119         addOneToIdSet,
 120         combineIdEnvs,
 121         delManyFromIdEnv,
 122         delOneFromIdEnv,
 123         elementOfIdSet,
 124         emptyIdSet,
 125         growIdEnv,
 126         growIdEnvList,
 127         idSetToList,
 128         intersectIdSets,
 129         isEmptyIdSet,
 130         isNullIdEnv,
 131         lookupIdEnv,
 132         lookupNoFailIdEnv,
 133         mapIdEnv,
 134         minusIdSet,
 135         mkIdEnv,
 136         mkIdSet,
 137         modifyIdEnv,
 138         modifyIdEnv_Directly,
 139         nullIdEnv,
 140         rngIdEnv,
 141         unionIdSets,
 142         unionManyIdSets,
 143         unitIdEnv,
 144         unitIdSet
 145     ) where
 146
 147 IMP_Ubiq()
 148 IMPORT_DELOOPER(IdLoop)   -- for paranoia checking
 149 IMPORT_DELOOPER(TyLoop)   -- for paranoia checking
 150
 151 import Bag
 152 import Class            ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
 153 import IdInfo
 154 import Maybes           ( maybeToBool )
 155 import Name             ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
 156                           mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName,
 157                           isLocallyDefinedName, occNameString, modAndOcc,
 158                           isLocallyDefined, changeUnique, isWiredInName,
 159                           nameString, getOccString, setNameVisibility,
 160                           isExported, ExportFlag(..), DefnInfo, Provenance,
 161                           OccName(..), Name
 162                         )
 163 import PrelMods         ( pREL_TUP, pREL_BASE )
 164 import Lex              ( mkTupNameStr )
 165 import FieldLabel       ( fieldLabelName, FieldLabel(..){-instances-} )
 166 import PragmaInfo       ( PragmaInfo(..) )
 167 import PprEnv           -- ( SYN_IE(NmbrM), NmbrEnv(..) )
 168 import PprType          ( getTypeString, specMaybeTysSuffix,
 169                           nmbrType, nmbrTyVar,
 170                           GenType, GenTyVar
 171                         )
 172 import PprStyle
 173 import Pretty
 174 import MatchEnv         ( MatchEnv )
 175 import SrcLoc           ( mkBuiltinSrcLoc )
 176 import TysWiredIn       ( tupleTyCon )
 177 import TyCon            ( TyCon, tyConDataCons )
 178 import Type             ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
 179                           applyTyCon, instantiateTy, mkForAllTys,
 180                           tyVarsOfType, applyTypeEnvToTy, typePrimRep,
 181                           GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
 182                         )
 183 import TyVar            ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
 184 import Usage            ( SYN_IE(UVar) )
 185 import UniqFM
 186 import UniqSet          -- practically all of it
 187 import Unique           ( getBuiltinUniques, pprUnique, showUnique,
 188                           incrUnique,
 189                           Unique{-instance Ord3-}
 190                         )
 191 import Util             ( mapAccumL, nOfThem, zipEqual, assoc,
 192                           panic, panic#, pprPanic, assertPanic
 193                         )
 194 \end{code}
 195
 196 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 197 follow.
 198
 199 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
 200 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
 201 strictness).  The essential info about different kinds of @Ids@ is
 202 in its @IdDetails@.
 203
 204 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 205
 206 \begin{code}
 207 data GenId ty = Id
 208         Unique          -- Key for fast comparison
 209         Name
 210         ty              -- Id's type; used all the time;
 211         IdDetails       -- Stuff about individual kinds of Ids.
 212         PragmaInfo      -- Properties of this Id requested by programmer
 213                         -- eg specialise-me, inline-me
 214         IdInfo          -- Properties of this Id deduced by compiler
 215
 216 type Id            = GenId Type
 217
 218 data StrictnessMark = MarkedStrict | NotMarkedStrict
 219
 220 data IdDetails
 221
 222   ---------------- Local values
 223
 224   = LocalId     Bool            -- Local name; mentioned by the user
 225                                 -- True <=> no free type vars
 226
 227   | SysLocalId  Bool            -- Local name; made up by the compiler
 228                                 -- as for LocalId
 229
 230   | PrimitiveId PrimOp          -- The Id for a primitive operation
 231
 232   | SpecPragmaId                -- Local name; introduced by the compiler
 233                  (Maybe Id)     -- for explicit specid in pragma
 234                  Bool           -- as for LocalId
 235
 236   ---------------- Global values
 237
 238   | ImportedId                  -- Global name (Imported or Implicit); Id imported from an interface
 239
 240   ---------------- Data constructors
 241
 242   | DataConId   ConTag
 243                 [StrictnessMark] -- Strict args; length = arity
 244                 [FieldLabel]    -- Field labels for this constructor
 245
 246                 [TyVar] [(Class,Type)] [Type] TyCon
 247                                 -- the type is:
 248                                 -- forall tyvars . theta_ty =>
 249                                 --    unitype_1 -> ... -> unitype_n -> tycon tyvars
 250
 251   | TupleConId  Int             -- Its arity
 252
 253   | RecordSelId FieldLabel
 254
 255   ---------------- Things to do with overloading
 256
 257   | SuperDictSelId              -- Selector for superclass dictionary
 258                 Class           -- The class (input dict)
 259                 Class           -- The superclass (result dict)
 260
 261   | MethodSelId Class           -- An overloaded class operation, with
 262                                 -- a fully polymorphic type.  Its code
 263                                 -- just selects a method from the
 264                                 -- dictionary.  The class.
 265                 ClassOp         -- The operation
 266
 267         -- NB: The IdInfo for a MethodSelId has all the info about its
 268         -- related "constant method Ids", which are just
 269         -- specialisations of this general one.
 270
 271   | DefaultMethodId             -- Default method for a particular class op
 272                 Class           -- same class, <blah-blah> info as MethodSelId
 273                 ClassOp         -- (surprise, surprise)
 274                 Bool            -- True <=> I *know* this default method Id
 275                                 -- is a generated one that just says
 276                                 -- `error "No default method for <op>"'.
 277
 278                                 -- see below
 279   | DictFunId   Class           -- A DictFun is uniquely identified
 280                 Type            -- by its class and type; this type has free type vars,
 281                                 -- whose identity is irrelevant.  Eg Class = Eq
 282                                 --                                   Type  = Tree a
 283                                 -- The "a" is irrelevant.  As it is too painful to
 284                                 -- actually do comparisons that way, we kindly supply
 285                                 -- a Unique for that purpose.
 286
 287                                 -- see below
 288   | ConstMethodId               -- A method which depends only on the type of the
 289                                 -- instance, and not on any further dictionaries etc.
 290                 Class           -- Uniquely identified by:
 291                 Type            -- (class, type, classop) triple
 292                 ClassOp
 293                 Module          -- module where instance came from
 294
 295   | InstId                      -- An instance of a dictionary, class operation,
 296                                 -- or overloaded value (Local name)
 297                 Bool            -- as for LocalId
 298
 299   | SpecId                      -- A specialisation of another Id
 300                 Id              -- Id of which this is a specialisation
 301                 [Maybe Type]    -- Types at which it is specialised;
 302                                 -- A "Nothing" says this type ain't relevant.
 303                 Bool            -- True <=> no free type vars; it's not enough
 304                                 -- to know about the unspec version, because
 305                                 -- we may specialise to a type w/ free tyvars
 306                                 -- (i.e., in one of the "Maybe Type" dudes).
 307
 308 -- Scheduled for deletion: SLPJ Nov 96
 309 -- Nobody seems to depend on knowing this.
 310   | WorkerId                    -- A "worker" for some other Id
 311                 Id              -- Id for which this is a worker
 312
 313 type ConTag     = Int
 314 type DictVar    = Id
 315 type DictFun    = Id
 316 type DataCon    = Id
 317 \end{code}
 318
 319 DictFunIds are generated from instance decls.
 320 \begin{verbatim}
 321         class Foo a where
 322           op :: a -> a -> Bool
 323
 324         instance Foo a => Foo [a] where
 325           op = ...
 326 \end{verbatim}
 327 generates the dict fun id decl
 328 \begin{verbatim}
 329         dfun.Foo.[*] = \d -> ...
 330 \end{verbatim}
 331 The dfun id is uniquely named by the (class, type) pair.  Notice, it
 332 isn't a (class,tycon) pair any more, because we may get manually or
 333 automatically generated specialisations of the instance decl:
 334 \begin{verbatim}
 335         instance Foo [Int] where
 336           op = ...
 337 \end{verbatim}
 338 generates
 339 \begin{verbatim}
 340         dfun.Foo.[Int] = ...
 341 \end{verbatim}
 342 The type variables in the name are irrelevant; we print them as stars.
 343
 344
 345 Constant method ids are generated from instance decls where
 346 there is no context; that is, no dictionaries are needed to
 347 construct the method.  Example
 348 \begin{verbatim}
 349         instance Foo Int where
 350           op = ...
 351 \end{verbatim}
 352 Then we get a constant method
 353 \begin{verbatim}
 354         Foo.op.Int = ...
 355 \end{verbatim}
 356
 357 It is possible, albeit unusual, to have a constant method
 358 for an instance decl which has type vars:
 359 \begin{verbatim}
 360         instance Foo [a] where
 361           op []     ys = True
 362           op (x:xs) ys = False
 363 \end{verbatim}
 364 We get the constant method
 365 \begin{verbatim}
 366         Foo.op.[*] = ...
 367 \end{verbatim}
 368 So a constant method is identified by a class/op/type triple.
 369 The type variables in the type are irrelevant.
 370
 371
 372 For Ids whose names must be known/deducible in other modules, we have
 373 to conjure up their worker's names (and their worker's worker's
 374 names... etc) in a known systematic way.
 375
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection[Id-documentation]{Documentation}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 [A BIT DATED [WDP]]
 384
 385 The @Id@ datatype describes {\em values}.  The basic things we want to
 386 know: (1)~a value's {\em type} (@idType@ is a very common
 387 operation in the compiler); and (2)~what ``flavour'' of value it might
 388 be---for example, it can be terribly useful to know that a value is a
 389 class method.
 390
 391 \begin{description}
 392 %----------------------------------------------------------------------
 393 \item[@DataConId@:] For the data constructors declared by a @data@
 394 declaration.  Their type is kept in {\em two} forms---as a regular
 395 @Type@ (in the usual place), and also in its constituent pieces (in
 396 the ``details''). We are frequently interested in those pieces.
 397
 398 %----------------------------------------------------------------------
 399 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
 400 the infinite family of tuples.
 401
 402 %----------------------------------------------------------------------
 403 \item[@ImportedId@:] These are values defined outside this module.
 404 {\em Everything} we want to know about them must be stored here (or in
 405 their @IdInfo@).
 406
 407 %----------------------------------------------------------------------
 408 \item[@MethodSelId@:] A selector from a dictionary; it may select either
 409 a method or a dictionary for one of the class's superclasses.
 410
 411 %----------------------------------------------------------------------
 412 \item[@DictFunId@:]
 413
 414 @mkDictFunId [a,b..] theta C T@ is the function derived from the
 415 instance declaration
 416
 417         instance theta => C (T a b ..) where
 418                 ...
 419
 420 It builds function @Id@ which maps dictionaries for theta,
 421 to a dictionary for C (T a b ..).
 422
 423 *Note* that with the ``Mark Jones optimisation'', the theta may
 424 include dictionaries for the immediate superclasses of C at the type
 425 (T a b ..).
 426
 427 %----------------------------------------------------------------------
 428 \item[@InstId@:]
 429
 430 %----------------------------------------------------------------------
 431 \item[@SpecId@:]
 432
 433 %----------------------------------------------------------------------
 434 \item[@WorkerId@:]
 435
 436 %----------------------------------------------------------------------
 437 \item[@LocalId@:] A purely-local value, e.g., a function argument,
 438 something defined in a @where@ clauses, ... --- but which appears in
 439 the original program text.
 440
 441 %----------------------------------------------------------------------
 442 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
 443 the original program text; these are introduced by the compiler in
 444 doing its thing.
 445
 446 %----------------------------------------------------------------------
 447 \item[@SpecPragmaId@:] Introduced by the compiler to record
 448 Specialisation pragmas. It is dead code which MUST NOT be removed
 449 before specialisation.
 450 \end{description}
 451
 452 Further remarks:
 453 \begin{enumerate}
 454 %----------------------------------------------------------------------
 455 \item
 456
 457 @DataCons@ @TupleCons@, @Importeds@, @SuperDictSelIds@,
 458 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 459 properties:
 460 \begin{itemize}
 461 \item
 462 They have no free type variables, so if you are making a
 463 type-variable substitution you don't need to look inside them.
 464 \item
 465 They are constants, so they are not free variables.  (When the STG
 466 machine makes a closure, it puts all the free variables in the
 467 closure; the above are not required.)
 468 \end{itemize}
 469 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
 470 properties, but they may not.
 471 \end{enumerate}
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection[Id-general-funs]{General @Id@-related functions}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
 481 isDataCon (Id _ _ _ (TupleConId _) _ _)            = True
 482 isDataCon (Id _ _ _ (SpecId unspec _ _) _ _)       = isDataCon unspec
 483 isDataCon other                                    = False
 484
 485 isTupleCon (Id _ _ _ (TupleConId _) _ _)         = True
 486 isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _)    = isTupleCon unspec
 487 isTupleCon other                                 = False
 488
 489 {-LATER:
 490 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
 491   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 492     Just (unspec, ty_maybes)
 493 isSpecId_maybe other_id
 494   = Nothing
 495
 496 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _)
 497   = Just specid
 498 isSpecPragmaId_maybe other_id
 499   = Nothing
 500 -}
 501 \end{code}
 502
 503 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
 504 @let(rec)@ (returns @False@), or whether it is {\em sure} to be
 505 defined at top level (returns @True@). This is used to decide whether
 506 the @Id@ is a candidate free variable. NB: you are only {\em sure}
 507 about something if it returns @True@!
 508
 509 \begin{code}
 510 toplevelishId     :: Id -> Bool
 511 idHasNoFreeTyVars :: Id -> Bool
 512
 513 toplevelishId (Id _ _ _ details _ _)
 514   = chk details
 515   where
 516     chk (DataConId _ _ _ _ _ _ _)   = True
 517     chk (TupleConId _)              = True
 518     chk (RecordSelId _)             = True
 519     chk ImportedId                  = True
 520     chk (SuperDictSelId _ _)        = True
 521     chk (MethodSelId _ _)           = True
 522     chk (DefaultMethodId _ _ _)     = True
 523     chk (DictFunId     _ _)         = True
 524     chk (ConstMethodId _ _ _ _)     = True
 525     chk (SpecId unspec _ _)         = toplevelishId unspec
 526                                     -- depends what the unspecialised thing is
 527     chk (WorkerId unwrkr)           = toplevelishId unwrkr
 528     chk (InstId       _)            = False     -- these are local
 529     chk (LocalId      _)            = False
 530     chk (SysLocalId   _)            = False
 531     chk (SpecPragmaId _ _)          = False
 532     chk (PrimitiveId _)             = True
 533
 534 idHasNoFreeTyVars (Id _ _ _ details _ info)
 535   = chk details
 536   where
 537     chk (DataConId _ _ _ _ _ _ _) = True
 538     chk (TupleConId _)            = True
 539     chk (RecordSelId _)           = True
 540     chk ImportedId                = True
 541     chk (SuperDictSelId _ _)      = True
 542     chk (MethodSelId _ _)         = True
 543     chk (DefaultMethodId _ _ _)   = True
 544     chk (DictFunId     _ _)       = True
 545     chk (ConstMethodId _ _ _ _)   = True
 546     chk (WorkerId unwrkr)         = idHasNoFreeTyVars unwrkr
 547     chk (SpecId _     _   no_free_tvs) = no_free_tvs
 548     chk (InstId         no_free_tvs) = no_free_tvs
 549     chk (LocalId        no_free_tvs) = no_free_tvs
 550     chk (SysLocalId     no_free_tvs) = no_free_tvs
 551     chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
 552     chk (PrimitiveId _)             = True
 553
 554 -- wantIdSigInIface decides whether to put an Id's type signature and
 555 -- IdInfo in an interface file
 556 wantIdSigInIface
 557         :: Bool         -- True <=> the thing is mentioned somewhere else in the
 558                         --          interface file
 559         -> Bool         -- True <=> omit anything that doesn't *have* to go
 560         -> Id
 561         -> Bool
 562
 563 wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _)
 564   = chk details
 565   where
 566     chk (LocalId _)       = isExported name &&
 567                             not (isWiredInName name)    -- User-declared thing!
 568     chk ImportedId        = False               -- Never put imports in interface file
 569     chk (PrimitiveId _)   = False               -- Ditto, for primitives
 570
 571         -- This group is Ids that are implied by their type or class decl;
 572         -- remember that all type and class decls appear in the interface file
 573     chk (DataConId _ _ _ _ _ _ _) = False
 574     chk (TupleConId _)            = False       -- Ditto
 575     chk (RecordSelId _)           = False       -- Ditto
 576     chk (SuperDictSelId _ _)      = False       -- Ditto
 577     chk (MethodSelId _ _)         = False       -- Ditto
 578     chk (ConstMethodId _ _ _ _)   = False       -- Scheduled for nuking
 579     chk (DefaultMethodId _ _ _)   = False                       -- Hmm.  No, for now
 580
 581         -- DictFunIds are more interesting, they may have IdInfo we can't
 582         -- get from the instance declaration.  We emit them if we're gung ho.
 583         -- No need to check the export flag; instance decls are always exposed
 584     chk (DictFunId     _ _)       = not omit_iface_prags
 585
 586         -- This group are only called out by being mentioned somewhere else
 587     chk (WorkerId unwrkr)         = mentioned_already
 588     chk (SpecId _ _ _)            = mentioned_already
 589     chk (InstId _)                = mentioned_already
 590     chk (SysLocalId _)            = mentioned_already
 591     chk (SpecPragmaId _ _)        = mentioned_already
 592 \end{code}
 593
 594 \begin{code}
 595 isImportedId (Id _ _ _ ImportedId _ _) = True
 596 isImportedId other                     = False
 597
 598 isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info)
 599
 600 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
 601 isSysLocalId other                         = False
 602
 603 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
 604 isSpecPragmaId other                             = False
 605
 606 isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op)
 607 isMethodSelId_maybe _                                   = Nothing
 608
 609 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
 610 isDefaultMethodId other                                  = False
 611
 612 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
 613   = Just (cls, clsop, err)
 614 isDefaultMethodId_maybe other = Nothing
 615
 616 isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True
 617 isDictFunId other                          = False
 618
 619 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
 620 isConstMethodId other                                  = False
 621
 622 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
 623   = Just (cls, ty, clsop)
 624 isConstMethodId_maybe other = Nothing
 625
 626 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
 627 isSuperDictSelId_maybe other_id                           = Nothing
 628
 629 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
 630 isWorkerId other                     = False
 631
 632 isWrapperId id = workerExists (getIdStrictness id)
 633
 634 isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
 635 isPrimitiveId_maybe other                               = Nothing
 636 \end{code}
 637
 638 Tell them who my wrapper function is.
 639 \begin{code}
 640 {-LATER:
 641 myWrapperMaybe :: Id -> Maybe Id
 642
 643 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
 644 myWrapperMaybe other_id                           = Nothing
 645 -}
 646 \end{code}
 647
 648 \begin{code}
 649 unfoldingUnfriendlyId   -- return True iff it is definitely a bad
 650         :: Id           -- idea to export an unfolding that
 651         -> Bool         -- mentions this Id.  Reason: it cannot
 652                         -- possibly be seen in another module.
 653
 654 unfoldingUnfriendlyId id = not (externallyVisibleId id)
 655 \end{code}
 656
 657 @externallyVisibleId@: is it true that another module might be
 658 able to ``see'' this Id in a code generation sense. That
 659 is, another .o file might refer to this Id.
 660
 661 In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
 662 local-ness precisely so that the test here would be easy
 663
 664 \begin{code}
 665 externallyVisibleId :: Id -> Bool
 666 externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name)
 667                      -- not local => global => externally visible
 668 \end{code}
 669
 670 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
 671 `Top-levelish Ids'' cannot have any free type variables, so applying
 672 the type-env cannot have any effect.  (NB: checked in CoreLint?)
 673
 674 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 675 former ``should be'' the usual crunch point.
 676
 677 \begin{code}
 678 type TypeEnv = TyVarEnv Type
 679
 680 applyTypeEnvToId :: TypeEnv -> Id -> Id
 681
 682 applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
 683   | idHasNoFreeTyVars id
 684   = id
 685   | otherwise
 686   = apply_to_Id ( \ ty ->
 687         applyTypeEnvToTy type_env ty
 688     ) id
 689 \end{code}
 690
 691 \begin{code}
 692 apply_to_Id :: (Type -> Type) -> Id -> Id
 693
 694 apply_to_Id ty_fn (Id u n ty details prag info)
 695   = let
 696         new_ty = ty_fn ty
 697     in
 698     Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
 699   where
 700     apply_to_details (SpecId unspec ty_maybes no_ftvs)
 701       = let
 702             new_unspec = apply_to_Id ty_fn unspec
 703             new_maybes = map apply_to_maybe ty_maybes
 704         in
 705         SpecId new_unspec new_maybes (no_free_tvs ty)
 706         -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
 707       where
 708         apply_to_maybe Nothing   = Nothing
 709         apply_to_maybe (Just ty) = Just (ty_fn ty)
 710
 711     apply_to_details (WorkerId unwrkr)
 712       = let
 713             new_unwrkr = apply_to_Id ty_fn unwrkr
 714         in
 715         WorkerId new_unwrkr
 716
 717     apply_to_details other = other
 718 \end{code}
 719
 720 Sadly, I don't think the one using the magic typechecker substitution
 721 can be done with @apply_to_Id@.  Here we go....
 722
 723 Strictness is very important here.  We can't leave behind thunks
 724 with pointers to the substitution: it {\em must} be single-threaded.
 725
 726 \begin{code}
 727 {-LATER:
 728 applySubstToId :: Subst -> Id -> (Subst, Id)
 729
 730 applySubstToId subst id@(Id u n ty info details)
 731   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
 732   -- because, in the typechecker, we are still
 733   -- *concocting* the types.
 734   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
 735     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
 736     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
 737     (s4, Id u n new_ty new_info new_details) }}}
 738   where
 739     apply_to_details subst _ (InstId inst no_ftvs)
 740       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
 741         (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
 742
 743     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
 744       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
 745         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 746         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 747         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
 748       where
 749         apply_to_maybe subst Nothing   = (subst, Nothing)
 750         apply_to_maybe subst (Just ty)
 751           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 752             (s2, Just new_ty) }
 753
 754     apply_to_details subst _ (WorkerId unwrkr)
 755       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
 756         (s2, WorkerId new_unwrkr) }
 757
 758     apply_to_details subst _ other = (subst, other)
 759 -}
 760 \end{code}
 761
 762 %************************************************************************
 763 %*                                                                      *
 764 \subsection[Id-type-funs]{Type-related @Id@ functions}
 765 %*                                                                      *
 766 %************************************************************************
 767
 768 \begin{code}
 769 idType :: GenId ty -> ty
 770
 771 idType (Id _ _ ty _ _ _) = ty
 772 \end{code}
 773
 774 \begin{code}
 775 {-LATER:
 776 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
 777
 778 getMentionedTyConsAndClassesFromId id
 779  = getMentionedTyConsAndClassesFromType (idType id)
 780 -}
 781 \end{code}
 782
 783 \begin{code}
 784 idPrimRep i = typePrimRep (idType i)
 785 \end{code}
 786
 787 %************************************************************************
 788 %*                                                                      *
 789 \subsection[Id-overloading]{Functions related to overloading}
 790 %*                                                                      *
 791 %************************************************************************
 792
 793 \begin{code}
 794 mkSuperDictSelId u clas sc ty
 795   = addStandardIdInfo $
 796     Id u name ty details NoPragmaInfo noIdInfo
 797   where
 798     name    = mkCompoundName name_fn u (getName clas)
 799     details = SuperDictSelId clas sc
 800     name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ
 801     (mod,occ) = modAndOcc sc
 802
 803         -- For method selectors the clean thing to do is
 804         -- to give the method selector the same name as the class op itself.
 805 mkMethodSelId op_name rec_c op ty
 806   = addStandardIdInfo $
 807     Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo
 808
 809 mkDefaultMethodId op_name uniq rec_c op gen ty
 810   = Id uniq dm_name ty details NoPragmaInfo noIdInfo
 811   where
 812     dm_name        = mkCompoundName name_fn uniq op_name
 813     details        = DefaultMethodId rec_c op gen
 814     name_fn op_str = SLIT("dm_") _APPEND_ op_str
 815
 816 mkDictFunId dfun_name full_ty clas ity
 817   = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
 818   where
 819     details  = DictFunId clas ity
 820
 821 mkConstMethodId uniq clas op ity full_ty from_here locn mod info
 822   = Id uniq name full_ty details NoPragmaInfo info
 823   where
 824     name     = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here
 825     details  = ConstMethodId clas ity op mod
 826     occ_name = classOpString op _APPEND_
 827                SLIT("_cm_") _APPEND_ renum_type_string full_ty ity
 828
 829 mkWorkerId u unwrkr ty info
 830   = Id u name ty details NoPragmaInfo info
 831   where
 832     name    = mkCompoundName name_fn u (getName unwrkr)
 833     details = WorkerId unwrkr
 834     name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk")
 835
 836 mkInstId u ty name
 837   = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 838
 839 {-LATER:
 840 getConstMethodId clas op ty
 841   = -- constant-method info is hidden in the IdInfo of
 842     -- the class-op id (as mentioned up above).
 843     let
 844         sel_id = getMethodSelId clas op
 845     in
 846     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
 847       Just xx -> xx
 848       Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
 849         ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
 850                ppr PprDebug sel_id],
 851         ppStr "(This can arise if an interface pragma refers to an instance",
 852         ppStr "but there is no imported interface which *defines* that instance.",
 853         ppStr "The info above, however ugly, should indicate what else you need to import."
 854         ])
 855 -}
 856
 857
 858 renum_type_string full_ty ity
 859   = initNmbr (
 860         nmbrType full_ty    `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
 861         nmbrType ity        `thenNmbr` \ rn_ity ->
 862         returnNmbr (getTypeString rn_ity)
 863     )
 864 \end{code}
 865
 866 %************************************************************************
 867 %*                                                                      *
 868 \subsection[local-funs]{@LocalId@-related functions}
 869 %*                                                                      *
 870 %************************************************************************
 871
 872 \begin{code}
 873 mkImported  n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
 874
 875 mkPrimitiveId n ty primop
 876   = addStandardIdInfo $
 877     Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo
 878 \end{code}
 879
 880 \begin{code}
 881 type MyTy a b = GenType (GenTyVar a) b
 882 type MyId a b = GenId (MyTy a b)
 883
 884 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
 885
 886 -- SysLocal: for an Id being created by the compiler out of thin air...
 887 -- UserLocal: an Id with a name the user might recognize...
 888 mkSysLocal  :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 889 mkUserLocal :: OccName     -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 890
 891 mkSysLocal str uniq ty loc
 892   = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 893
 894 mkUserLocal occ uniq ty loc
 895   = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 896
 897 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
 898 mkUserId name ty pragma_info
 899   = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
 900 \end{code}
 901
 902
 903 \begin{code}
 904 {-LATER:
 905
 906 -- for a SpecPragmaId being created by the compiler out of thin air...
 907 mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
 908 mkSpecPragmaId str uniq ty specid loc
 909   = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
 910
 911 -- for new SpecId
 912 mkSpecId u unspec ty_maybes ty info
 913   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 914     Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
 915
 916 -- Specialised version of constructor: only used in STG and code generation
 917 -- Note: The specialsied Id has the same unique as the unspeced Id
 918
 919 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
 920   = ASSERT(isDataCon unspec)
 921     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 922     Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
 923   where
 924     new_ty = specialiseTy ty ty_maybes 0
 925
 926 localiseId :: Id -> Id
 927 localiseId id@(Id u n ty info details)
 928   = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
 929   where
 930     name = getOccName id
 931     loc  = getSrcLoc id
 932 -}
 933
 934 -- See notes with setNameVisibility (Name.lhs)
 935 setIdVisibility :: Module -> Id -> Id
 936 setIdVisibility mod (Id uniq name ty details prag info)
 937   = Id uniq (setNameVisibility mod name) ty details prag info
 938
 939 mkIdWithNewUniq :: Id -> Unique -> Id
 940 mkIdWithNewUniq (Id _ n ty details prag info) u
 941   = Id u (changeUnique n u) ty details prag info
 942 \end{code}
 943
 944 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
 945 @Uniques@, but that's OK because the templates are supposed to be
 946 instantiated before use.
 947 \begin{code}
 948 mkTemplateLocals :: [Type] -> [Id]
 949 mkTemplateLocals tys
 950   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
 951             (getBuiltinUniques (length tys))
 952             tys
 953 \end{code}
 954
 955 \begin{code}
 956 getIdInfo     :: GenId ty -> IdInfo
 957 getPragmaInfo :: GenId ty -> PragmaInfo
 958
 959 getIdInfo     (Id _ _ _ _ _ info) = info
 960 getPragmaInfo (Id _ _ _ _ info _) = info
 961
 962 replaceIdInfo :: Id -> IdInfo -> Id
 963
 964 replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
 965
 966 {-LATER:
 967 selectIdInfoForSpecId :: Id -> IdInfo
 968 selectIdInfoForSpecId unspec
 969   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 970     noIdInfo `addUnfoldInfo` getIdUnfolding unspec
 971 -}
 972 \end{code}
 973
 974 %************************************************************************
 975 %*                                                                      *
 976 \subsection[Id-arities]{Arity-related functions}
 977 %*                                                                      *
 978 %************************************************************************
 979
 980 For locally-defined Ids, the code generator maintains its own notion
 981 of their arities; so it should not be asking...  (but other things
 982 besides the code-generator need arity info!)
 983
 984 \begin{code}
 985 getIdArity :: Id -> ArityInfo
 986 getIdArity id@(Id _ _ _ _ _ id_info)
 987   = --ASSERT( not (isDataCon id))
 988     arityInfo id_info
 989
 990 dataConArity, dataConNumFields :: DataCon -> Int
 991
 992 dataConArity id@(Id _ _ _ _ _ id_info)
 993   = ASSERT(isDataCon id)
 994     case arityInfo id_info of
 995       ArityExactly a -> a
 996       other          -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
 997
 998 dataConNumFields id
 999   = ASSERT(isDataCon id)
1000     case (dataConSig id) of { (_, _, arg_tys, _) ->
1001     length arg_tys }
1002
1003 isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
1004
1005 addIdArity :: Id -> ArityInfo -> Id
1006 addIdArity (Id u n ty details pinfo info) arity
1007   = Id u n ty details pinfo (info `addArityInfo` arity)
1008 \end{code}
1009
1010 %************************************************************************
1011 %*                                                                      *
1012 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1013 %*                                                                      *
1014 %************************************************************************
1015
1016 \begin{code}
1017 mkDataCon :: Name
1018           -> [StrictnessMark] -> [FieldLabel]
1019           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1020           -> Id
1021   -- can get the tag and all the pieces of the type from the Type
1022
1023 mkDataCon n stricts fields tvs ctxt args_tys tycon
1024   = ASSERT(length stricts == length args_tys)
1025     addStandardIdInfo data_con
1026   where
1027     -- NB: data_con self-recursion; should be OK as tags are not
1028     -- looked at until late in the game.
1029     data_con
1030       = Id (nameUnique n)
1031            n
1032            data_con_ty
1033            (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1034            IWantToBeINLINEd     -- Always inline constructors if possible
1035            noIdInfo
1036
1037     data_con_tag    = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
1038     data_con_family = tyConDataCons tycon
1039
1040     data_con_ty
1041       = mkSigmaTy tvs ctxt
1042         (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1043
1044
1045 mkTupleCon :: Arity -> Name -> Type -> Id
1046 mkTupleCon arity name ty
1047   = addStandardIdInfo tuple_id
1048   where
1049     tuple_id = Id (nameUnique name) name ty
1050                   (TupleConId arity)
1051                   IWantToBeINLINEd              -- Always inline constructors if possible
1052                   noIdInfo
1053
1054 fIRST_TAG :: ConTag
1055 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1056 \end{code}
1057
1058 \begin{code}
1059 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1060 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1061 dataConTag (Id _ _ _ (TupleConId _) _ _)              = fIRST_TAG
1062 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _)         = dataConTag unspec
1063
1064 dataConTyCon :: DataCon -> TyCon        -- will panic if not a DataCon
1065 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1066 dataConTyCon (Id _ _ _ (TupleConId a) _ _)                = tupleTyCon a
1067
1068 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1069                                         -- will panic if not a DataCon
1070
1071 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1072   = (tyvars, theta_ty, arg_tys, tycon)
1073
1074 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1075   = (tyvars, [], tyvar_tys, tupleTyCon arity)
1076   where
1077     tyvars      = take arity alphaTyVars
1078     tyvar_tys   = mkTyVarTys tyvars
1079
1080
1081 -- dataConRepType returns the type of the representation of a contructor
1082 -- This may differ from the type of the contructor Id itself for two reasons:
1083 --      a) the constructor Id may be overloaded, but the dictionary isn't stored
1084 --      b) the constructor may store an unboxed version of a strict field.
1085 -- Here's an example illustrating both:
1086 --      data Ord a => T a = MkT Int! a
1087 -- Here
1088 --      T :: Ord a => Int -> a -> T a
1089 -- but the rep type is
1090 --      Trep :: Int# -> a -> T a
1091 -- Actually, the unboxed part isn't implemented yet!
1092
1093 dataConRepType :: GenId (GenType tv u) -> GenType tv u
1094 dataConRepType con
1095   = mkForAllTys tyvars tau
1096   where
1097     (tyvars, theta, tau) = splitSigmaTy (idType con)
1098
1099 dataConFieldLabels :: DataCon -> [FieldLabel]
1100 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1101 dataConFieldLabels (Id _ _ _ (TupleConId _)                 _ _) = []
1102
1103 dataConStrictMarks :: DataCon -> [StrictnessMark]
1104 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1105 dataConStrictMarks (Id _ _ _ (TupleConId arity)              _ _)
1106   = nOfThem arity NotMarkedStrict
1107
1108 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
1109 dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
1110
1111 dataConArgTys :: DataCon
1112               -> [Type]         -- Instantiated at these types
1113               -> [Type]         -- Needs arguments of these types
1114 dataConArgTys con_id inst_tys
1115  = map (instantiateTy tenv) arg_tys
1116  where
1117     (tyvars, _, arg_tys, _) = dataConSig con_id
1118     tenv                    = zipEqual "dataConArgTys" tyvars inst_tys
1119 \end{code}
1120
1121 \begin{code}
1122 mkRecordSelId field_label selector_ty
1123   = addStandardIdInfo $         -- Record selectors have a standard unfolding
1124     Id (nameUnique name)
1125        name
1126        selector_ty
1127        (RecordSelId field_label)
1128        NoPragmaInfo
1129        noIdInfo
1130   where
1131     name = fieldLabelName field_label
1132
1133 recordSelectorFieldLabel :: Id -> FieldLabel
1134 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1135
1136 isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True
1137 isRecordSelector other                            = False
1138 \end{code}
1139
1140
1141 Data type declarations are of the form:
1142 \begin{verbatim}
1143 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1144 \end{verbatim}
1145 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1146 @C1 x y z@, we want a function binding:
1147 \begin{verbatim}
1148 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1149 \end{verbatim}
1150 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1151 2nd-order polymorphic lambda calculus with explicit types.
1152
1153 %************************************************************************
1154 %*                                                                      *
1155 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1156 %*                                                                      *
1157 %************************************************************************
1158
1159 \begin{code}
1160 getIdUnfolding :: Id -> Unfolding
1161
1162 getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info
1163
1164 addIdUnfolding :: Id -> Unfolding -> Id
1165 addIdUnfolding id@(Id u n ty details prag info) unfolding
1166   = Id u n ty details prag (info `addUnfoldInfo` unfolding)
1167 \end{code}
1168
1169 The inline pragma tells us to be very keen to inline this Id, but it's still
1170 OK not to if optimisation is switched off.
1171
1172 \begin{code}
1173 idWantsToBeINLINEd :: Id -> Bool
1174
1175 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
1176 idWantsToBeINLINEd _                               = False
1177
1178 addInlinePragma :: Id -> Id
1179 addInlinePragma (Id u sn ty details _ info)
1180   = Id u sn ty details IWantToBeINLINEd info
1181 \end{code}
1182
1183
1184 The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined.
1185 It's only true for primitives, because we don't want to make a closure for each of them.
1186
1187 \begin{code}
1188 idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True
1189 idMustBeINLINEd other                               = False
1190 \end{code}
1191
1192
1193 %************************************************************************
1194 %*                                                                      *
1195 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1196 %*                                                                      *
1197 %************************************************************************
1198
1199 \begin{code}
1200 getIdDemandInfo :: Id -> DemandInfo
1201 getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info
1202
1203 addIdDemandInfo :: Id -> DemandInfo -> Id
1204 addIdDemandInfo (Id u n ty details prags info) demand_info
1205   = Id u n ty details prags (info `addDemandInfo` demand_info)
1206 \end{code}
1207
1208 \begin{code}
1209 getIdUpdateInfo :: Id -> UpdateInfo
1210 getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info
1211
1212 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1213 addIdUpdateInfo (Id u n ty details prags info) upd_info
1214   = Id u n ty details prags (info `addUpdateInfo` upd_info)
1215 \end{code}
1216
1217 \begin{code}
1218 {- LATER:
1219 getIdArgUsageInfo :: Id -> ArgUsageInfo
1220 getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info
1221
1222 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1223 addIdArgUsageInfo (Id u n ty info details) au_info
1224   = Id u n ty (info `addArgusageInfo` au_info) details
1225 -}
1226 \end{code}
1227
1228 \begin{code}
1229 {- LATER:
1230 getIdFBTypeInfo :: Id -> FBTypeInfo
1231 getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info
1232
1233 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1234 addIdFBTypeInfo (Id u n ty info details) upd_info
1235   = Id u n ty (info `addFBTypeInfo` upd_info) details
1236 -}
1237 \end{code}
1238
1239 \begin{code}
1240 getIdSpecialisation :: Id -> SpecEnv
1241 getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
1242
1243 addIdSpecialisation :: Id -> SpecEnv -> Id
1244 addIdSpecialisation (Id u n ty details prags info) spec_info
1245   = Id u n ty details prags (info `addSpecInfo` spec_info)
1246 \end{code}
1247
1248 Strictness: we snaffle the info out of the IdInfo.
1249
1250 \begin{code}
1251 getIdStrictness :: Id -> StrictnessInfo Id
1252
1253 getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
1254
1255 addIdStrictness :: Id -> StrictnessInfo Id -> Id
1256 addIdStrictness (Id u n ty details prags info) strict_info
1257   = Id u n ty details prags (info `addStrictnessInfo` strict_info)
1258 \end{code}
1259
1260 %************************************************************************
1261 %*                                                                      *
1262 \subsection[Id-comparison]{Comparison functions for @Id@s}
1263 %*                                                                      *
1264 %************************************************************************
1265
1266 Comparison: equality and ordering---this stuff gets {\em hammered}.
1267
1268 \begin{code}
1269 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1270 -- short and very sweet
1271 \end{code}
1272
1273 \begin{code}
1274 instance Ord3 (GenId ty) where
1275     cmp = cmpId
1276
1277 instance Eq (GenId ty) where
1278     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
1279     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True  }
1280
1281 instance Ord (GenId ty) where
1282     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1283     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1284     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1285     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1286     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1287 \end{code}
1288
1289 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1290 account when comparing two data constructors. We need to do this
1291 because a specialised data constructor has the same Unique as its
1292 unspecialised counterpart.
1293
1294 \begin{code}
1295 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1296
1297 cmpId_withSpecDataCon id1 id2
1298   | eq_ids && isDataCon id1 && isDataCon id2
1299   = cmpEqDataCon id1 id2
1300
1301   | otherwise
1302   = cmp_ids
1303   where
1304     cmp_ids = cmpId id1 id2
1305     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1306
1307 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1308   = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1309
1310 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1311 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1312 cmpEqDataCon _                             _ = EQ_
1313 \end{code}
1314
1315 %************************************************************************
1316 %*                                                                      *
1317 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1318 %*                                                                      *
1319 %************************************************************************
1320
1321 \begin{code}
1322 instance Outputable ty => Outputable (GenId ty) where
1323     ppr sty id = pprId sty id
1324
1325 -- and a SPECIALIZEd one:
1326 instance Outputable {-Id, i.e.:-}(GenId Type) where
1327     ppr sty id = pprId sty id
1328
1329 showId :: PprStyle -> Id -> String
1330 showId sty id = ppShow 80 (pprId sty id)
1331 \end{code}
1332
1333 Default printing code (not used for interfaces):
1334 \begin{code}
1335 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1336
1337 pprId sty (Id u n _ _ _ _) = ppr sty n
1338   -- WDP 96/05/06: We can re-elaborate this as we go along...
1339 \end{code}
1340
1341 \begin{code}
1342 idUnique (Id u _ _ _ _ _) = u
1343
1344 instance Uniquable (GenId ty) where
1345     uniqueOf = idUnique
1346
1347 instance NamedThing (GenId ty) where
1348     getName this_id@(Id u n _ details _ _) = n
1349 \end{code}
1350
1351 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1352 the @Uniques@ out of local @Ids@ given to it.
1353
1354 %************************************************************************
1355 %*                                                                      *
1356 \subsection{@IdEnv@s and @IdSet@s}
1357 %*                                                                      *
1358 %************************************************************************
1359
1360 \begin{code}
1361 type IdEnv elt = UniqFM elt
1362
1363 nullIdEnv         :: IdEnv a
1364
1365 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1366 unitIdEnv         :: GenId ty -> a -> IdEnv a
1367 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
1368 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
1369 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1370
1371 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
1372 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
1373 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1374 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
1375 modifyIdEnv       :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
1376 rngIdEnv          :: IdEnv a -> [a]
1377
1378 isNullIdEnv       :: IdEnv a -> Bool
1379 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
1380 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1381 \end{code}
1382
1383 \begin{code}
1384 addOneToIdEnv    = addToUFM
1385 combineIdEnvs    = plusUFM_C
1386 delManyFromIdEnv = delListFromUFM
1387 delOneFromIdEnv  = delFromUFM
1388 growIdEnv        = plusUFM
1389 lookupIdEnv      = lookupUFM
1390 mapIdEnv         = mapUFM
1391 mkIdEnv          = listToUFM
1392 nullIdEnv        = emptyUFM
1393 rngIdEnv         = eltsUFM
1394 unitIdEnv        = unitUFM
1395
1396 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
1397 isNullIdEnv       env       = sizeUFM env == 0
1398 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
1399
1400 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1401 -- modify function, and put it back.
1402
1403 modifyIdEnv mangle_fn env key
1404   = case (lookupIdEnv env key) of
1405       Nothing -> env
1406       Just xx -> addOneToIdEnv env key (mangle_fn xx)
1407
1408 modifyIdEnv_Directly mangle_fn env key
1409   = case (lookupUFM_Directly env key) of
1410       Nothing -> env
1411       Just xx -> addToUFM_Directly env key (mangle_fn xx)
1412 \end{code}
1413
1414 \begin{code}
1415 type GenIdSet ty = UniqSet (GenId ty)
1416 type IdSet       = UniqSet (GenId Type)
1417
1418 emptyIdSet      :: GenIdSet ty
1419 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1420 unionIdSets     :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1421 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1422 idSetToList     :: GenIdSet ty -> [GenId ty]
1423 unitIdSet       :: GenId ty -> GenIdSet ty
1424 addOneToIdSet   :: GenIdSet ty -> GenId ty -> GenIdSet ty
1425 elementOfIdSet  :: GenId ty -> GenIdSet ty -> Bool
1426 minusIdSet      :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1427 isEmptyIdSet    :: GenIdSet ty -> Bool
1428 mkIdSet         :: [GenId ty] -> GenIdSet ty
1429
1430 emptyIdSet      = emptyUniqSet
1431 unitIdSet       = unitUniqSet
1432 addOneToIdSet   = addOneToUniqSet
1433 intersectIdSets = intersectUniqSets
1434 unionIdSets     = unionUniqSets
1435 unionManyIdSets = unionManyUniqSets
1436 idSetToList     = uniqSetToList
1437 elementOfIdSet  = elementOfUniqSet
1438 minusIdSet      = minusUniqSet
1439 isEmptyIdSet    = isEmptyUniqSet
1440 mkIdSet         = mkUniqSet
1441 \end{code}
1442
1443 \begin{code}
1444 addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id
1445
1446 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1447   = case (lookupUFM_Directly idenv u) of
1448       Just xx -> trace "addId: already in map!" $
1449                  (nenv, xx)
1450       Nothing ->
1451         if toplevelishId id then
1452             trace "addId: can't add toplevelish!" $
1453             (nenv, id)
1454         else -- alloc a new unique for this guy
1455              -- and add an entry in the idenv
1456              -- NB: *** KNOT-TYING ***
1457             let
1458                 nenv_plus_id    = NmbrEnv (incrUnique ui) ut uu
1459                                           (addToUFM_Directly idenv u new_id)
1460                                           tvenv uvenv
1461
1462                 (nenv2, new_ty)  = nmbrType     ty  nenv_plus_id
1463                 (nenv3, new_det) = nmbr_details det nenv2
1464
1465                 new_id = Id ui n new_ty new_det prag info
1466             in
1467             (nenv3, new_id)
1468
1469 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1470   = case (lookupUFM_Directly idenv u) of
1471       Just xx -> (nenv, xx)
1472       Nothing ->
1473         if not (toplevelishId id) then
1474             trace "nmbrId: lookup failed" $
1475             (nenv, id)
1476         else
1477             let
1478                 (nenv2, new_ty)  = nmbrType     ty  nenv
1479                 (nenv3, new_det) = nmbr_details det nenv2
1480
1481                 new_id = Id u n new_ty new_det prag info
1482             in
1483             (nenv3, new_id)
1484
1485     -- used when renumbering TyCons to produce data decls...
1486 nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
1487   = (nenv, id) -- nothing to do for tuples
1488
1489 nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1490   = case (lookupUFM_Directly idenv u) of
1491       Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
1492       Nothing ->
1493         let
1494             (nenv2, new_fields)  = (mapNmbr nmbrField  fields)  nenv
1495             (nenv3, new_arg_tys) = (mapNmbr nmbrType   arg_tys) nenv2
1496
1497             new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
1498             new_id  = Id u n (bottom "ty") new_det prag info
1499         in
1500         (nenv3, new_id)
1501   where
1502     bottom msg = panic ("nmbrDataCon"++msg)
1503
1504 ------------
1505 nmbr_details :: IdDetails -> NmbrM IdDetails
1506
1507 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1508   = mapNmbr nmbrTyVar  tvs      `thenNmbr` \ new_tvs ->
1509     mapNmbr nmbrField  fields   `thenNmbr` \ new_fields ->
1510     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
1511     mapNmbr nmbrType   arg_tys  `thenNmbr` \ new_arg_tys ->
1512     returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1513   where
1514     nmbr_theta (c,t)
1515       = --nmbrClass c   `thenNmbr` \ new_c ->
1516         nmbrType  t     `thenNmbr` \ new_t ->
1517         returnNmbr (c, new_t)
1518
1519     -- ToDo:add more cases as needed
1520 nmbr_details other_details = returnNmbr other_details
1521
1522 ------------
1523 nmbrField (FieldLabel n ty tag)
1524   = nmbrType ty `thenNmbr` \ new_ty ->
1525     returnNmbr (FieldLabel n new_ty tag)
1526 \end{code}