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         omitIfaceSigForId,
  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,
 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 -- omitIfaceSigForId tells whether an Id's info is implied by other declarations,
 555 -- so we don't need to put its signature in an interface file, even if it's mentioned
 556 -- in some other interface unfolding.
 557
 558 omitIfaceSigForId
 559         :: Id
 560         -> Bool
 561
 562 omitIfaceSigForId (Id _ name _ details _ _)
 563   | isWiredInName name
 564   = True
 565
 566   | otherwise
 567   = case details of
 568         ImportedId        -> True               -- Never put imports in interface file
 569         (PrimitiveId _)   -> True               -- 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         -- The dfun id must *not* be omitted, because it carries version info for
 574         -- the instance decl
 575         (DataConId _ _ _ _ _ _ _) -> True
 576         (TupleConId _)            -> True
 577         (RecordSelId _)           -> True
 578         (SuperDictSelId _ _)      -> True
 579         (MethodSelId _ _)         -> True
 580
 581         other                     -> False      -- Don't omit!
 582                 -- NB DefaultMethodIds are not omitted
 583 \end{code}
 584
 585 \begin{code}
 586 isImportedId (Id _ _ _ ImportedId _ _) = True
 587 isImportedId other                     = False
 588
 589 isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info)
 590
 591 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
 592 isSysLocalId other                         = False
 593
 594 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
 595 isSpecPragmaId other                             = False
 596
 597 isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op)
 598 isMethodSelId_maybe _                                   = Nothing
 599
 600 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
 601 isDefaultMethodId other                                  = False
 602
 603 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
 604   = Just (cls, clsop, err)
 605 isDefaultMethodId_maybe other = Nothing
 606
 607 isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True
 608 isDictFunId other                          = False
 609
 610 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
 611 isConstMethodId other                                  = False
 612
 613 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
 614   = Just (cls, ty, clsop)
 615 isConstMethodId_maybe other = Nothing
 616
 617 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
 618 isSuperDictSelId_maybe other_id                           = Nothing
 619
 620 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
 621 isWorkerId other                     = False
 622
 623 isWrapperId id = workerExists (getIdStrictness id)
 624
 625 isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
 626 isPrimitiveId_maybe other                               = Nothing
 627 \end{code}
 628
 629 Tell them who my wrapper function is.
 630 \begin{code}
 631 {-LATER:
 632 myWrapperMaybe :: Id -> Maybe Id
 633
 634 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
 635 myWrapperMaybe other_id                           = Nothing
 636 -}
 637 \end{code}
 638
 639 \begin{code}
 640 unfoldingUnfriendlyId   -- return True iff it is definitely a bad
 641         :: Id           -- idea to export an unfolding that
 642         -> Bool         -- mentions this Id.  Reason: it cannot
 643                         -- possibly be seen in another module.
 644
 645 unfoldingUnfriendlyId id = not (externallyVisibleId id)
 646 \end{code}
 647
 648 @externallyVisibleId@: is it true that another module might be
 649 able to ``see'' this Id in a code generation sense. That
 650 is, another .o file might refer to this Id.
 651
 652 In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
 653 local-ness precisely so that the test here would be easy
 654
 655 \begin{code}
 656 externallyVisibleId :: Id -> Bool
 657 externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name)
 658                      -- not local => global => externally visible
 659 \end{code}
 660
 661 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
 662 `Top-levelish Ids'' cannot have any free type variables, so applying
 663 the type-env cannot have any effect.  (NB: checked in CoreLint?)
 664
 665 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 666 former ``should be'' the usual crunch point.
 667
 668 \begin{code}
 669 type TypeEnv = TyVarEnv Type
 670
 671 applyTypeEnvToId :: TypeEnv -> Id -> Id
 672
 673 applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
 674   | idHasNoFreeTyVars id
 675   = id
 676   | otherwise
 677   = apply_to_Id ( \ ty ->
 678         applyTypeEnvToTy type_env ty
 679     ) id
 680 \end{code}
 681
 682 \begin{code}
 683 apply_to_Id :: (Type -> Type) -> Id -> Id
 684
 685 apply_to_Id ty_fn (Id u n ty details prag info)
 686   = let
 687         new_ty = ty_fn ty
 688     in
 689     Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
 690   where
 691     apply_to_details (SpecId unspec ty_maybes no_ftvs)
 692       = let
 693             new_unspec = apply_to_Id ty_fn unspec
 694             new_maybes = map apply_to_maybe ty_maybes
 695         in
 696         SpecId new_unspec new_maybes (no_free_tvs ty)
 697         -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
 698       where
 699         apply_to_maybe Nothing   = Nothing
 700         apply_to_maybe (Just ty) = Just (ty_fn ty)
 701
 702     apply_to_details (WorkerId unwrkr)
 703       = let
 704             new_unwrkr = apply_to_Id ty_fn unwrkr
 705         in
 706         WorkerId new_unwrkr
 707
 708     apply_to_details other = other
 709 \end{code}
 710
 711 Sadly, I don't think the one using the magic typechecker substitution
 712 can be done with @apply_to_Id@.  Here we go....
 713
 714 Strictness is very important here.  We can't leave behind thunks
 715 with pointers to the substitution: it {\em must} be single-threaded.
 716
 717 \begin{code}
 718 {-LATER:
 719 applySubstToId :: Subst -> Id -> (Subst, Id)
 720
 721 applySubstToId subst id@(Id u n ty info details)
 722   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
 723   -- because, in the typechecker, we are still
 724   -- *concocting* the types.
 725   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
 726     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
 727     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
 728     (s4, Id u n new_ty new_info new_details) }}}
 729   where
 730     apply_to_details subst _ (InstId inst no_ftvs)
 731       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
 732         (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
 733
 734     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
 735       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
 736         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 737         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 738         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
 739       where
 740         apply_to_maybe subst Nothing   = (subst, Nothing)
 741         apply_to_maybe subst (Just ty)
 742           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 743             (s2, Just new_ty) }
 744
 745     apply_to_details subst _ (WorkerId unwrkr)
 746       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
 747         (s2, WorkerId new_unwrkr) }
 748
 749     apply_to_details subst _ other = (subst, other)
 750 -}
 751 \end{code}
 752
 753 %************************************************************************
 754 %*                                                                      *
 755 \subsection[Id-type-funs]{Type-related @Id@ functions}
 756 %*                                                                      *
 757 %************************************************************************
 758
 759 \begin{code}
 760 idType :: GenId ty -> ty
 761
 762 idType (Id _ _ ty _ _ _) = ty
 763 \end{code}
 764
 765 \begin{code}
 766 {-LATER:
 767 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
 768
 769 getMentionedTyConsAndClassesFromId id
 770  = getMentionedTyConsAndClassesFromType (idType id)
 771 -}
 772 \end{code}
 773
 774 \begin{code}
 775 idPrimRep i = typePrimRep (idType i)
 776 \end{code}
 777
 778 %************************************************************************
 779 %*                                                                      *
 780 \subsection[Id-overloading]{Functions related to overloading}
 781 %*                                                                      *
 782 %************************************************************************
 783
 784 \begin{code}
 785 mkSuperDictSelId u clas sc ty
 786   = addStandardIdInfo $
 787     Id u name ty details NoPragmaInfo noIdInfo
 788   where
 789     name    = mkCompoundName name_fn u (getName clas)
 790     details = SuperDictSelId clas sc
 791     name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ
 792     (mod,occ) = modAndOcc sc
 793
 794         -- For method selectors the clean thing to do is
 795         -- to give the method selector the same name as the class op itself.
 796 mkMethodSelId op_name rec_c op ty
 797   = addStandardIdInfo $
 798     Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo
 799
 800 mkDefaultMethodId dm_name rec_c op gen ty
 801   = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c op gen) NoPragmaInfo noIdInfo
 802
 803 mkDictFunId dfun_name full_ty clas ity
 804   = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
 805   where
 806     details  = DictFunId clas ity
 807
 808 mkConstMethodId uniq clas op ity full_ty from_here locn mod info
 809   = Id uniq name full_ty details NoPragmaInfo info
 810   where
 811     name     = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here
 812     details  = ConstMethodId clas ity op mod
 813     occ_name = classOpString op _APPEND_
 814                SLIT("_cm_") _APPEND_ renum_type_string full_ty ity
 815
 816 mkWorkerId u unwrkr ty info
 817   = Id u name ty details NoPragmaInfo info
 818   where
 819     name    = mkCompoundName name_fn u (getName unwrkr)
 820     details = WorkerId unwrkr
 821     name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
 822
 823 mkInstId u ty name
 824   = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 825
 826 {-LATER:
 827 getConstMethodId clas op ty
 828   = -- constant-method info is hidden in the IdInfo of
 829     -- the class-op id (as mentioned up above).
 830     let
 831         sel_id = getMethodSelId clas op
 832     in
 833     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
 834       Just xx -> xx
 835       Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
 836         ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
 837                ppr PprDebug sel_id],
 838         ppStr "(This can arise if an interface pragma refers to an instance",
 839         ppStr "but there is no imported interface which *defines* that instance.",
 840         ppStr "The info above, however ugly, should indicate what else you need to import."
 841         ])
 842 -}
 843
 844
 845 renum_type_string full_ty ity
 846   = initNmbr (
 847         nmbrType full_ty    `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
 848         nmbrType ity        `thenNmbr` \ rn_ity ->
 849         returnNmbr (getTypeString rn_ity)
 850     )
 851 \end{code}
 852
 853 %************************************************************************
 854 %*                                                                      *
 855 \subsection[local-funs]{@LocalId@-related functions}
 856 %*                                                                      *
 857 %************************************************************************
 858
 859 \begin{code}
 860 mkImported  n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
 861
 862 mkPrimitiveId n ty primop
 863   = addStandardIdInfo $
 864     Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo
 865
 866 \end{code}
 867
 868 \begin{code}
 869
 870 type MyTy a b = GenType (GenTyVar a) b
 871 type MyId a b = GenId (MyTy a b)
 872
 873 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
 874
 875 -- SysLocal: for an Id being created by the compiler out of thin air...
 876 -- UserLocal: an Id with a name the user might recognize...
 877 mkSysLocal  :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 878 mkUserLocal :: OccName     -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 879
 880 mkSysLocal str uniq ty loc
 881   = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 882
 883 mkUserLocal occ uniq ty loc
 884   = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 885
 886 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
 887 mkUserId name ty pragma_info
 888   = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
 889 \end{code}
 890
 891
 892 \begin{code}
 893 {-LATER:
 894
 895 -- for a SpecPragmaId being created by the compiler out of thin air...
 896 mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
 897 mkSpecPragmaId str uniq ty specid loc
 898   = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
 899
 900 -- for new SpecId
 901 mkSpecId u unspec ty_maybes ty info
 902   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 903     Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
 904
 905 -- Specialised version of constructor: only used in STG and code generation
 906 -- Note: The specialsied Id has the same unique as the unspeced Id
 907
 908 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
 909   = ASSERT(isDataCon unspec)
 910     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 911     Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
 912   where
 913     new_ty = specialiseTy ty ty_maybes 0
 914
 915 localiseId :: Id -> Id
 916 localiseId id@(Id u n ty info details)
 917   = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
 918   where
 919     name = getOccName id
 920     loc  = getSrcLoc id
 921 -}
 922
 923 -- See notes with setNameVisibility (Name.lhs)
 924 setIdVisibility :: Module -> Id -> Id
 925 setIdVisibility mod (Id uniq name ty details prag info)
 926   = Id uniq (setNameVisibility mod name) ty details prag info
 927
 928 mkIdWithNewUniq :: Id -> Unique -> Id
 929 mkIdWithNewUniq (Id _ n ty details prag info) u
 930   = Id u (changeUnique n u) ty details prag info
 931 \end{code}
 932
 933 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
 934 @Uniques@, but that's OK because the templates are supposed to be
 935 instantiated before use.
 936 \begin{code}
 937 mkTemplateLocals :: [Type] -> [Id]
 938 mkTemplateLocals tys
 939   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
 940             (getBuiltinUniques (length tys))
 941             tys
 942 \end{code}
 943
 944 \begin{code}
 945 getIdInfo     :: GenId ty -> IdInfo
 946 getPragmaInfo :: GenId ty -> PragmaInfo
 947
 948 getIdInfo     (Id _ _ _ _ _ info) = info
 949 getPragmaInfo (Id _ _ _ _ info _) = info
 950
 951 replaceIdInfo :: Id -> IdInfo -> Id
 952
 953 replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
 954
 955 {-LATER:
 956 selectIdInfoForSpecId :: Id -> IdInfo
 957 selectIdInfoForSpecId unspec
 958   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 959     noIdInfo `addUnfoldInfo` getIdUnfolding unspec
 960 -}
 961 \end{code}
 962
 963 %************************************************************************
 964 %*                                                                      *
 965 \subsection[Id-arities]{Arity-related functions}
 966 %*                                                                      *
 967 %************************************************************************
 968
 969 For locally-defined Ids, the code generator maintains its own notion
 970 of their arities; so it should not be asking...  (but other things
 971 besides the code-generator need arity info!)
 972
 973 \begin{code}
 974 getIdArity :: Id -> ArityInfo
 975 getIdArity id@(Id _ _ _ _ _ id_info)
 976   = --ASSERT( not (isDataCon id))
 977     arityInfo id_info
 978
 979 dataConArity, dataConNumFields :: DataCon -> Int
 980
 981 dataConArity id@(Id _ _ _ _ _ id_info)
 982   = ASSERT(isDataCon id)
 983     case arityInfo id_info of
 984       ArityExactly a -> a
 985       other          -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
 986
 987 dataConNumFields id
 988   = ASSERT(isDataCon id)
 989     case (dataConSig id) of { (_, _, arg_tys, _) ->
 990     length arg_tys }
 991
 992 isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
 993
 994 addIdArity :: Id -> ArityInfo -> Id
 995 addIdArity (Id u n ty details pinfo info) arity
 996   = Id u n ty details pinfo (info `addArityInfo` arity)
 997 \end{code}
 998
 999 %************************************************************************
1000 %*                                                                      *
1001 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1002 %*                                                                      *
1003 %************************************************************************
1004
1005 \begin{code}
1006 mkDataCon :: Name
1007           -> [StrictnessMark] -> [FieldLabel]
1008           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1009           -> Id
1010   -- can get the tag and all the pieces of the type from the Type
1011
1012 mkDataCon n stricts fields tvs ctxt args_tys tycon
1013   = ASSERT(length stricts == length args_tys)
1014     addStandardIdInfo data_con
1015   where
1016     -- NB: data_con self-recursion; should be OK as tags are not
1017     -- looked at until late in the game.
1018     data_con
1019       = Id (nameUnique n)
1020            n
1021            data_con_ty
1022            (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1023            IWantToBeINLINEd     -- Always inline constructors if possible
1024            noIdInfo
1025
1026     data_con_tag    = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
1027     data_con_family = tyConDataCons tycon
1028
1029     data_con_ty
1030       = mkSigmaTy tvs ctxt
1031         (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1032
1033
1034 mkTupleCon :: Arity -> Name -> Type -> Id
1035 mkTupleCon arity name ty
1036   = addStandardIdInfo tuple_id
1037   where
1038     tuple_id = Id (nameUnique name) name ty
1039                   (TupleConId arity)
1040                   IWantToBeINLINEd              -- Always inline constructors if possible
1041                   noIdInfo
1042
1043 fIRST_TAG :: ConTag
1044 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1045 \end{code}
1046
1047 \begin{code}
1048 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1049 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1050 dataConTag (Id _ _ _ (TupleConId _) _ _)              = fIRST_TAG
1051 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _)         = dataConTag unspec
1052
1053 dataConTyCon :: DataCon -> TyCon        -- will panic if not a DataCon
1054 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1055 dataConTyCon (Id _ _ _ (TupleConId a) _ _)                = tupleTyCon a
1056
1057 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1058                                         -- will panic if not a DataCon
1059
1060 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1061   = (tyvars, theta_ty, arg_tys, tycon)
1062
1063 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1064   = (tyvars, [], tyvar_tys, tupleTyCon arity)
1065   where
1066     tyvars      = take arity alphaTyVars
1067     tyvar_tys   = mkTyVarTys tyvars
1068
1069
1070 -- dataConRepType returns the type of the representation of a contructor
1071 -- This may differ from the type of the contructor Id itself for two reasons:
1072 --      a) the constructor Id may be overloaded, but the dictionary isn't stored
1073 --      b) the constructor may store an unboxed version of a strict field.
1074 -- Here's an example illustrating both:
1075 --      data Ord a => T a = MkT Int! a
1076 -- Here
1077 --      T :: Ord a => Int -> a -> T a
1078 -- but the rep type is
1079 --      Trep :: Int# -> a -> T a
1080 -- Actually, the unboxed part isn't implemented yet!
1081
1082 dataConRepType :: GenId (GenType tv u) -> GenType tv u
1083 dataConRepType con
1084   = mkForAllTys tyvars tau
1085   where
1086     (tyvars, theta, tau) = splitSigmaTy (idType con)
1087
1088 dataConFieldLabels :: DataCon -> [FieldLabel]
1089 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1090 dataConFieldLabels (Id _ _ _ (TupleConId _)                 _ _) = []
1091
1092 dataConStrictMarks :: DataCon -> [StrictnessMark]
1093 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1094 dataConStrictMarks (Id _ _ _ (TupleConId arity)              _ _)
1095   = nOfThem arity NotMarkedStrict
1096
1097 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
1098 dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
1099
1100 dataConArgTys :: DataCon
1101               -> [Type]         -- Instantiated at these types
1102               -> [Type]         -- Needs arguments of these types
1103 dataConArgTys con_id inst_tys
1104  = map (instantiateTy tenv) arg_tys
1105  where
1106     (tyvars, _, arg_tys, _) = dataConSig con_id
1107     tenv                    = zipEqual "dataConArgTys" tyvars inst_tys
1108 \end{code}
1109
1110 \begin{code}
1111 mkRecordSelId field_label selector_ty
1112   = addStandardIdInfo $         -- Record selectors have a standard unfolding
1113     Id (nameUnique name)
1114        name
1115        selector_ty
1116        (RecordSelId field_label)
1117        NoPragmaInfo
1118        noIdInfo
1119   where
1120     name = fieldLabelName field_label
1121
1122 recordSelectorFieldLabel :: Id -> FieldLabel
1123 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1124
1125 isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True
1126 isRecordSelector other                            = False
1127 \end{code}
1128
1129
1130 Data type declarations are of the form:
1131 \begin{verbatim}
1132 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1133 \end{verbatim}
1134 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1135 @C1 x y z@, we want a function binding:
1136 \begin{verbatim}
1137 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1138 \end{verbatim}
1139 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1140 2nd-order polymorphic lambda calculus with explicit types.
1141
1142 %************************************************************************
1143 %*                                                                      *
1144 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1145 %*                                                                      *
1146 %************************************************************************
1147
1148 \begin{code}
1149 getIdUnfolding :: Id -> Unfolding
1150
1151 getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info
1152
1153 addIdUnfolding :: Id -> Unfolding -> Id
1154 addIdUnfolding id@(Id u n ty details prag info) unfolding
1155   = Id u n ty details prag (info `addUnfoldInfo` unfolding)
1156 \end{code}
1157
1158 The inline pragma tells us to be very keen to inline this Id, but it's still
1159 OK not to if optimisation is switched off.
1160
1161 \begin{code}
1162 idWantsToBeINLINEd :: Id -> Bool
1163
1164 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
1165 idWantsToBeINLINEd _                               = False
1166
1167 addInlinePragma :: Id -> Id
1168 addInlinePragma (Id u sn ty details _ info)
1169   = Id u sn ty details IWantToBeINLINEd info
1170 \end{code}
1171
1172
1173 The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined.
1174 It's only true for primitives, because we don't want to make a closure for each of them.
1175
1176 \begin{code}
1177 idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True
1178 idMustBeINLINEd other                               = False
1179 \end{code}
1180
1181
1182 %************************************************************************
1183 %*                                                                      *
1184 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1185 %*                                                                      *
1186 %************************************************************************
1187
1188 \begin{code}
1189 getIdDemandInfo :: Id -> DemandInfo
1190 getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info
1191
1192 addIdDemandInfo :: Id -> DemandInfo -> Id
1193 addIdDemandInfo (Id u n ty details prags info) demand_info
1194   = Id u n ty details prags (info `addDemandInfo` demand_info)
1195 \end{code}
1196
1197 \begin{code}
1198 getIdUpdateInfo :: Id -> UpdateInfo
1199 getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info
1200
1201 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1202 addIdUpdateInfo (Id u n ty details prags info) upd_info
1203   = Id u n ty details prags (info `addUpdateInfo` upd_info)
1204 \end{code}
1205
1206 \begin{code}
1207 {- LATER:
1208 getIdArgUsageInfo :: Id -> ArgUsageInfo
1209 getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info
1210
1211 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1212 addIdArgUsageInfo (Id u n ty info details) au_info
1213   = Id u n ty (info `addArgusageInfo` au_info) details
1214 -}
1215 \end{code}
1216
1217 \begin{code}
1218 {- LATER:
1219 getIdFBTypeInfo :: Id -> FBTypeInfo
1220 getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info
1221
1222 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1223 addIdFBTypeInfo (Id u n ty info details) upd_info
1224   = Id u n ty (info `addFBTypeInfo` upd_info) details
1225 -}
1226 \end{code}
1227
1228 \begin{code}
1229 getIdSpecialisation :: Id -> SpecEnv
1230 getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
1231
1232 addIdSpecialisation :: Id -> SpecEnv -> Id
1233 addIdSpecialisation (Id u n ty details prags info) spec_info
1234   = Id u n ty details prags (info `addSpecInfo` spec_info)
1235 \end{code}
1236
1237 Strictness: we snaffle the info out of the IdInfo.
1238
1239 \begin{code}
1240 getIdStrictness :: Id -> StrictnessInfo Id
1241
1242 getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
1243
1244 addIdStrictness :: Id -> StrictnessInfo Id -> Id
1245 addIdStrictness (Id u n ty details prags info) strict_info
1246   = Id u n ty details prags (info `addStrictnessInfo` strict_info)
1247 \end{code}
1248
1249 %************************************************************************
1250 %*                                                                      *
1251 \subsection[Id-comparison]{Comparison functions for @Id@s}
1252 %*                                                                      *
1253 %************************************************************************
1254
1255 Comparison: equality and ordering---this stuff gets {\em hammered}.
1256
1257 \begin{code}
1258 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1259 -- short and very sweet
1260 \end{code}
1261
1262 \begin{code}
1263 instance Ord3 (GenId ty) where
1264     cmp = cmpId
1265
1266 instance Eq (GenId ty) where
1267     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
1268     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True  }
1269
1270 instance Ord (GenId ty) where
1271     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1272     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1273     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1274     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1275     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1276 \end{code}
1277
1278 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1279 account when comparing two data constructors. We need to do this
1280 because a specialised data constructor has the same Unique as its
1281 unspecialised counterpart.
1282
1283 \begin{code}
1284 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1285
1286 cmpId_withSpecDataCon id1 id2
1287   | eq_ids && isDataCon id1 && isDataCon id2
1288   = cmpEqDataCon id1 id2
1289
1290   | otherwise
1291   = cmp_ids
1292   where
1293     cmp_ids = cmpId id1 id2
1294     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1295
1296 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1297   = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1298
1299 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1300 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1301 cmpEqDataCon _                             _ = EQ_
1302 \end{code}
1303
1304 %************************************************************************
1305 %*                                                                      *
1306 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1307 %*                                                                      *
1308 %************************************************************************
1309
1310 \begin{code}
1311 instance Outputable ty => Outputable (GenId ty) where
1312     ppr sty id = pprId sty id
1313
1314 -- and a SPECIALIZEd one:
1315 instance Outputable {-Id, i.e.:-}(GenId Type) where
1316     ppr sty id = pprId sty id
1317
1318 showId :: PprStyle -> Id -> String
1319 showId sty id = ppShow 80 (pprId sty id)
1320 \end{code}
1321
1322 Default printing code (not used for interfaces):
1323 \begin{code}
1324 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1325
1326 pprId sty (Id u n _ _ _ _) = ppr sty n
1327   -- WDP 96/05/06: We can re-elaborate this as we go along...
1328 \end{code}
1329
1330 \begin{code}
1331 idUnique (Id u _ _ _ _ _) = u
1332
1333 instance Uniquable (GenId ty) where
1334     uniqueOf = idUnique
1335
1336 instance NamedThing (GenId ty) where
1337     getName this_id@(Id u n _ details _ _) = n
1338 \end{code}
1339
1340 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1341 the @Uniques@ out of local @Ids@ given to it.
1342
1343 %************************************************************************
1344 %*                                                                      *
1345 \subsection{@IdEnv@s and @IdSet@s}
1346 %*                                                                      *
1347 %************************************************************************
1348
1349 \begin{code}
1350 type IdEnv elt = UniqFM elt
1351
1352 nullIdEnv         :: IdEnv a
1353
1354 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1355 unitIdEnv         :: GenId ty -> a -> IdEnv a
1356 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
1357 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
1358 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1359
1360 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
1361 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
1362 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1363 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
1364 modifyIdEnv       :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
1365 rngIdEnv          :: IdEnv a -> [a]
1366
1367 isNullIdEnv       :: IdEnv a -> Bool
1368 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
1369 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1370 \end{code}
1371
1372 \begin{code}
1373 addOneToIdEnv    = addToUFM
1374 combineIdEnvs    = plusUFM_C
1375 delManyFromIdEnv = delListFromUFM
1376 delOneFromIdEnv  = delFromUFM
1377 growIdEnv        = plusUFM
1378 lookupIdEnv      = lookupUFM
1379 mapIdEnv         = mapUFM
1380 mkIdEnv          = listToUFM
1381 nullIdEnv        = emptyUFM
1382 rngIdEnv         = eltsUFM
1383 unitIdEnv        = unitUFM
1384
1385 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
1386 isNullIdEnv       env       = sizeUFM env == 0
1387 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
1388
1389 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1390 -- modify function, and put it back.
1391
1392 modifyIdEnv mangle_fn env key
1393   = case (lookupIdEnv env key) of
1394       Nothing -> env
1395       Just xx -> addOneToIdEnv env key (mangle_fn xx)
1396
1397 modifyIdEnv_Directly mangle_fn env key
1398   = case (lookupUFM_Directly env key) of
1399       Nothing -> env
1400       Just xx -> addToUFM_Directly env key (mangle_fn xx)
1401 \end{code}
1402
1403 \begin{code}
1404 type GenIdSet ty = UniqSet (GenId ty)
1405 type IdSet       = UniqSet (GenId Type)
1406
1407 emptyIdSet      :: GenIdSet ty
1408 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1409 unionIdSets     :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1410 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1411 idSetToList     :: GenIdSet ty -> [GenId ty]
1412 unitIdSet       :: GenId ty -> GenIdSet ty
1413 addOneToIdSet   :: GenIdSet ty -> GenId ty -> GenIdSet ty
1414 elementOfIdSet  :: GenId ty -> GenIdSet ty -> Bool
1415 minusIdSet      :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1416 isEmptyIdSet    :: GenIdSet ty -> Bool
1417 mkIdSet         :: [GenId ty] -> GenIdSet ty
1418
1419 emptyIdSet      = emptyUniqSet
1420 unitIdSet       = unitUniqSet
1421 addOneToIdSet   = addOneToUniqSet
1422 intersectIdSets = intersectUniqSets
1423 unionIdSets     = unionUniqSets
1424 unionManyIdSets = unionManyUniqSets
1425 idSetToList     = uniqSetToList
1426 elementOfIdSet  = elementOfUniqSet
1427 minusIdSet      = minusUniqSet
1428 isEmptyIdSet    = isEmptyUniqSet
1429 mkIdSet         = mkUniqSet
1430 \end{code}
1431
1432 \begin{code}
1433 addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id
1434
1435 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1436   = case (lookupUFM_Directly idenv u) of
1437       Just xx -> trace "addId: already in map!" $
1438                  (nenv, xx)
1439       Nothing ->
1440         if toplevelishId id then
1441             trace "addId: can't add toplevelish!" $
1442             (nenv, id)
1443         else -- alloc a new unique for this guy
1444              -- and add an entry in the idenv
1445              -- NB: *** KNOT-TYING ***
1446             let
1447                 nenv_plus_id    = NmbrEnv (incrUnique ui) ut uu
1448                                           (addToUFM_Directly idenv u new_id)
1449                                           tvenv uvenv
1450
1451                 (nenv2, new_ty)  = nmbrType     ty  nenv_plus_id
1452                 (nenv3, new_det) = nmbr_details det nenv2
1453
1454                 new_id = Id ui n new_ty new_det prag info
1455             in
1456             (nenv3, new_id)
1457
1458 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1459   = case (lookupUFM_Directly idenv u) of
1460       Just xx -> (nenv, xx)
1461       Nothing ->
1462         if not (toplevelishId id) then
1463             trace "nmbrId: lookup failed" $
1464             (nenv, id)
1465         else
1466             let
1467                 (nenv2, new_ty)  = nmbrType     ty  nenv
1468                 (nenv3, new_det) = nmbr_details det nenv2
1469
1470                 new_id = Id u n new_ty new_det prag info
1471             in
1472             (nenv3, new_id)
1473
1474     -- used when renumbering TyCons to produce data decls...
1475 nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
1476   = (nenv, id) -- nothing to do for tuples
1477
1478 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)
1479   = case (lookupUFM_Directly idenv u) of
1480       Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
1481       Nothing ->
1482         let
1483             (nenv2, new_fields)  = (mapNmbr nmbrField  fields)  nenv
1484             (nenv3, new_arg_tys) = (mapNmbr nmbrType   arg_tys) nenv2
1485
1486             new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
1487             new_id  = Id u n (bottom "ty") new_det prag info
1488         in
1489         (nenv3, new_id)
1490   where
1491     bottom msg = panic ("nmbrDataCon"++msg)
1492
1493 ------------
1494 nmbr_details :: IdDetails -> NmbrM IdDetails
1495
1496 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1497   = mapNmbr nmbrTyVar  tvs      `thenNmbr` \ new_tvs ->
1498     mapNmbr nmbrField  fields   `thenNmbr` \ new_fields ->
1499     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
1500     mapNmbr nmbrType   arg_tys  `thenNmbr` \ new_arg_tys ->
1501     returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1502   where
1503     nmbr_theta (c,t)
1504       = --nmbrClass c   `thenNmbr` \ new_c ->
1505         nmbrType  t     `thenNmbr` \ new_t ->
1506         returnNmbr (c, new_t)
1507
1508     -- ToDo:add more cases as needed
1509 nmbr_details other_details = returnNmbr other_details
1510
1511 ------------
1512 nmbrField (FieldLabel n ty tag)
1513   = nmbrType ty `thenNmbr` \ new_ty ->
1514     returnNmbr (FieldLabel n new_ty tag)
1515 \end{code}