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 op_name uniq rec_c op gen ty
 801   = Id uniq dm_name ty details NoPragmaInfo noIdInfo
 802   where
 803     dm_name        = mkCompoundName name_fn uniq op_name
 804     details        = DefaultMethodId rec_c op gen
 805     name_fn op_str = SLIT("dm_") _APPEND_ op_str
 806
 807 mkDictFunId dfun_name full_ty clas ity
 808   = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
 809   where
 810     details  = DictFunId clas ity
 811
 812 mkConstMethodId uniq clas op ity full_ty from_here locn mod info
 813   = Id uniq name full_ty details NoPragmaInfo info
 814   where
 815     name     = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here
 816     details  = ConstMethodId clas ity op mod
 817     occ_name = classOpString op _APPEND_
 818                SLIT("_cm_") _APPEND_ renum_type_string full_ty ity
 819
 820 mkWorkerId u unwrkr ty info
 821   = Id u name ty details NoPragmaInfo info
 822   where
 823     name    = mkCompoundName name_fn u (getName unwrkr)
 824     details = WorkerId unwrkr
 825     name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk")
 826
 827 mkInstId u ty name
 828   = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 829
 830 {-LATER:
 831 getConstMethodId clas op ty
 832   = -- constant-method info is hidden in the IdInfo of
 833     -- the class-op id (as mentioned up above).
 834     let
 835         sel_id = getMethodSelId clas op
 836     in
 837     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
 838       Just xx -> xx
 839       Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
 840         ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
 841                ppr PprDebug sel_id],
 842         ppStr "(This can arise if an interface pragma refers to an instance",
 843         ppStr "but there is no imported interface which *defines* that instance.",
 844         ppStr "The info above, however ugly, should indicate what else you need to import."
 845         ])
 846 -}
 847
 848
 849 renum_type_string full_ty ity
 850   = initNmbr (
 851         nmbrType full_ty    `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
 852         nmbrType ity        `thenNmbr` \ rn_ity ->
 853         returnNmbr (getTypeString rn_ity)
 854     )
 855 \end{code}
 856
 857 %************************************************************************
 858 %*                                                                      *
 859 \subsection[local-funs]{@LocalId@-related functions}
 860 %*                                                                      *
 861 %************************************************************************
 862
 863 \begin{code}
 864 mkImported  n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
 865
 866 mkPrimitiveId n ty primop
 867   = addStandardIdInfo $
 868     Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo
 869 \end{code}
 870
 871 \begin{code}
 872 type MyTy a b = GenType (GenTyVar a) b
 873 type MyId a b = GenId (MyTy a b)
 874
 875 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
 876
 877 -- SysLocal: for an Id being created by the compiler out of thin air...
 878 -- UserLocal: an Id with a name the user might recognize...
 879 mkSysLocal  :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 880 mkUserLocal :: OccName     -> Unique -> MyTy a b -> SrcLoc -> MyId a b
 881
 882 mkSysLocal str uniq ty loc
 883   = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 884
 885 mkUserLocal occ uniq ty loc
 886   = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
 887
 888 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
 889 mkUserId name ty pragma_info
 890   = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
 891 \end{code}
 892
 893
 894 \begin{code}
 895 {-LATER:
 896
 897 -- for a SpecPragmaId being created by the compiler out of thin air...
 898 mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
 899 mkSpecPragmaId str uniq ty specid loc
 900   = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
 901
 902 -- for new SpecId
 903 mkSpecId u unspec ty_maybes ty info
 904   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 905     Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
 906
 907 -- Specialised version of constructor: only used in STG and code generation
 908 -- Note: The specialsied Id has the same unique as the unspeced Id
 909
 910 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
 911   = ASSERT(isDataCon unspec)
 912     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 913     Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
 914   where
 915     new_ty = specialiseTy ty ty_maybes 0
 916
 917 localiseId :: Id -> Id
 918 localiseId id@(Id u n ty info details)
 919   = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
 920   where
 921     name = getOccName id
 922     loc  = getSrcLoc id
 923 -}
 924
 925 -- See notes with setNameVisibility (Name.lhs)
 926 setIdVisibility :: Module -> Id -> Id
 927 setIdVisibility mod (Id uniq name ty details prag info)
 928   = Id uniq (setNameVisibility mod name) ty details prag info
 929
 930 mkIdWithNewUniq :: Id -> Unique -> Id
 931 mkIdWithNewUniq (Id _ n ty details prag info) u
 932   = Id u (changeUnique n u) ty details prag info
 933 \end{code}
 934
 935 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
 936 @Uniques@, but that's OK because the templates are supposed to be
 937 instantiated before use.
 938 \begin{code}
 939 mkTemplateLocals :: [Type] -> [Id]
 940 mkTemplateLocals tys
 941   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
 942             (getBuiltinUniques (length tys))
 943             tys
 944 \end{code}
 945
 946 \begin{code}
 947 getIdInfo     :: GenId ty -> IdInfo
 948 getPragmaInfo :: GenId ty -> PragmaInfo
 949
 950 getIdInfo     (Id _ _ _ _ _ info) = info
 951 getPragmaInfo (Id _ _ _ _ info _) = info
 952
 953 replaceIdInfo :: Id -> IdInfo -> Id
 954
 955 replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
 956
 957 {-LATER:
 958 selectIdInfoForSpecId :: Id -> IdInfo
 959 selectIdInfoForSpecId unspec
 960   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 961     noIdInfo `addUnfoldInfo` getIdUnfolding unspec
 962 -}
 963 \end{code}
 964
 965 %************************************************************************
 966 %*                                                                      *
 967 \subsection[Id-arities]{Arity-related functions}
 968 %*                                                                      *
 969 %************************************************************************
 970
 971 For locally-defined Ids, the code generator maintains its own notion
 972 of their arities; so it should not be asking...  (but other things
 973 besides the code-generator need arity info!)
 974
 975 \begin{code}
 976 getIdArity :: Id -> ArityInfo
 977 getIdArity id@(Id _ _ _ _ _ id_info)
 978   = --ASSERT( not (isDataCon id))
 979     arityInfo id_info
 980
 981 dataConArity, dataConNumFields :: DataCon -> Int
 982
 983 dataConArity id@(Id _ _ _ _ _ id_info)
 984   = ASSERT(isDataCon id)
 985     case arityInfo id_info of
 986       ArityExactly a -> a
 987       other          -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
 988
 989 dataConNumFields id
 990   = ASSERT(isDataCon id)
 991     case (dataConSig id) of { (_, _, arg_tys, _) ->
 992     length arg_tys }
 993
 994 isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
 995
 996 addIdArity :: Id -> ArityInfo -> Id
 997 addIdArity (Id u n ty details pinfo info) arity
 998   = Id u n ty details pinfo (info `addArityInfo` arity)
 999 \end{code}
1000
1001 %************************************************************************
1002 %*                                                                      *
1003 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1004 %*                                                                      *
1005 %************************************************************************
1006
1007 \begin{code}
1008 mkDataCon :: Name
1009           -> [StrictnessMark] -> [FieldLabel]
1010           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1011           -> Id
1012   -- can get the tag and all the pieces of the type from the Type
1013
1014 mkDataCon n stricts fields tvs ctxt args_tys tycon
1015   = ASSERT(length stricts == length args_tys)
1016     addStandardIdInfo data_con
1017   where
1018     -- NB: data_con self-recursion; should be OK as tags are not
1019     -- looked at until late in the game.
1020     data_con
1021       = Id (nameUnique n)
1022            n
1023            data_con_ty
1024            (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1025            IWantToBeINLINEd     -- Always inline constructors if possible
1026            noIdInfo
1027
1028     data_con_tag    = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
1029     data_con_family = tyConDataCons tycon
1030
1031     data_con_ty
1032       = mkSigmaTy tvs ctxt
1033         (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1034
1035
1036 mkTupleCon :: Arity -> Name -> Type -> Id
1037 mkTupleCon arity name ty
1038   = addStandardIdInfo tuple_id
1039   where
1040     tuple_id = Id (nameUnique name) name ty
1041                   (TupleConId arity)
1042                   IWantToBeINLINEd              -- Always inline constructors if possible
1043                   noIdInfo
1044
1045 fIRST_TAG :: ConTag
1046 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1047 \end{code}
1048
1049 \begin{code}
1050 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1051 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1052 dataConTag (Id _ _ _ (TupleConId _) _ _)              = fIRST_TAG
1053 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _)         = dataConTag unspec
1054
1055 dataConTyCon :: DataCon -> TyCon        -- will panic if not a DataCon
1056 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1057 dataConTyCon (Id _ _ _ (TupleConId a) _ _)                = tupleTyCon a
1058
1059 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1060                                         -- will panic if not a DataCon
1061
1062 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1063   = (tyvars, theta_ty, arg_tys, tycon)
1064
1065 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1066   = (tyvars, [], tyvar_tys, tupleTyCon arity)
1067   where
1068     tyvars      = take arity alphaTyVars
1069     tyvar_tys   = mkTyVarTys tyvars
1070
1071
1072 -- dataConRepType returns the type of the representation of a contructor
1073 -- This may differ from the type of the contructor Id itself for two reasons:
1074 --      a) the constructor Id may be overloaded, but the dictionary isn't stored
1075 --      b) the constructor may store an unboxed version of a strict field.
1076 -- Here's an example illustrating both:
1077 --      data Ord a => T a = MkT Int! a
1078 -- Here
1079 --      T :: Ord a => Int -> a -> T a
1080 -- but the rep type is
1081 --      Trep :: Int# -> a -> T a
1082 -- Actually, the unboxed part isn't implemented yet!
1083
1084 dataConRepType :: GenId (GenType tv u) -> GenType tv u
1085 dataConRepType con
1086   = mkForAllTys tyvars tau
1087   where
1088     (tyvars, theta, tau) = splitSigmaTy (idType con)
1089
1090 dataConFieldLabels :: DataCon -> [FieldLabel]
1091 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1092 dataConFieldLabels (Id _ _ _ (TupleConId _)                 _ _) = []
1093
1094 dataConStrictMarks :: DataCon -> [StrictnessMark]
1095 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1096 dataConStrictMarks (Id _ _ _ (TupleConId arity)              _ _)
1097   = nOfThem arity NotMarkedStrict
1098
1099 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
1100 dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
1101
1102 dataConArgTys :: DataCon
1103               -> [Type]         -- Instantiated at these types
1104               -> [Type]         -- Needs arguments of these types
1105 dataConArgTys con_id inst_tys
1106  = map (instantiateTy tenv) arg_tys
1107  where
1108     (tyvars, _, arg_tys, _) = dataConSig con_id
1109     tenv                    = zipEqual "dataConArgTys" tyvars inst_tys
1110 \end{code}
1111
1112 \begin{code}
1113 mkRecordSelId field_label selector_ty
1114   = addStandardIdInfo $         -- Record selectors have a standard unfolding
1115     Id (nameUnique name)
1116        name
1117        selector_ty
1118        (RecordSelId field_label)
1119        NoPragmaInfo
1120        noIdInfo
1121   where
1122     name = fieldLabelName field_label
1123
1124 recordSelectorFieldLabel :: Id -> FieldLabel
1125 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1126
1127 isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True
1128 isRecordSelector other                            = False
1129 \end{code}
1130
1131
1132 Data type declarations are of the form:
1133 \begin{verbatim}
1134 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1135 \end{verbatim}
1136 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1137 @C1 x y z@, we want a function binding:
1138 \begin{verbatim}
1139 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1140 \end{verbatim}
1141 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1142 2nd-order polymorphic lambda calculus with explicit types.
1143
1144 %************************************************************************
1145 %*                                                                      *
1146 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1147 %*                                                                      *
1148 %************************************************************************
1149
1150 \begin{code}
1151 getIdUnfolding :: Id -> Unfolding
1152
1153 getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info
1154
1155 addIdUnfolding :: Id -> Unfolding -> Id
1156 addIdUnfolding id@(Id u n ty details prag info) unfolding
1157   = Id u n ty details prag (info `addUnfoldInfo` unfolding)
1158 \end{code}
1159
1160 The inline pragma tells us to be very keen to inline this Id, but it's still
1161 OK not to if optimisation is switched off.
1162
1163 \begin{code}
1164 idWantsToBeINLINEd :: Id -> Bool
1165
1166 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
1167 idWantsToBeINLINEd _                               = False
1168
1169 addInlinePragma :: Id -> Id
1170 addInlinePragma (Id u sn ty details _ info)
1171   = Id u sn ty details IWantToBeINLINEd info
1172 \end{code}
1173
1174
1175 The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined.
1176 It's only true for primitives, because we don't want to make a closure for each of them.
1177
1178 \begin{code}
1179 idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True
1180 idMustBeINLINEd other                               = False
1181 \end{code}
1182
1183
1184 %************************************************************************
1185 %*                                                                      *
1186 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1187 %*                                                                      *
1188 %************************************************************************
1189
1190 \begin{code}
1191 getIdDemandInfo :: Id -> DemandInfo
1192 getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info
1193
1194 addIdDemandInfo :: Id -> DemandInfo -> Id
1195 addIdDemandInfo (Id u n ty details prags info) demand_info
1196   = Id u n ty details prags (info `addDemandInfo` demand_info)
1197 \end{code}
1198
1199 \begin{code}
1200 getIdUpdateInfo :: Id -> UpdateInfo
1201 getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info
1202
1203 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1204 addIdUpdateInfo (Id u n ty details prags info) upd_info
1205   = Id u n ty details prags (info `addUpdateInfo` upd_info)
1206 \end{code}
1207
1208 \begin{code}
1209 {- LATER:
1210 getIdArgUsageInfo :: Id -> ArgUsageInfo
1211 getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info
1212
1213 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1214 addIdArgUsageInfo (Id u n ty info details) au_info
1215   = Id u n ty (info `addArgusageInfo` au_info) details
1216 -}
1217 \end{code}
1218
1219 \begin{code}
1220 {- LATER:
1221 getIdFBTypeInfo :: Id -> FBTypeInfo
1222 getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info
1223
1224 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1225 addIdFBTypeInfo (Id u n ty info details) upd_info
1226   = Id u n ty (info `addFBTypeInfo` upd_info) details
1227 -}
1228 \end{code}
1229
1230 \begin{code}
1231 getIdSpecialisation :: Id -> SpecEnv
1232 getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
1233
1234 addIdSpecialisation :: Id -> SpecEnv -> Id
1235 addIdSpecialisation (Id u n ty details prags info) spec_info
1236   = Id u n ty details prags (info `addSpecInfo` spec_info)
1237 \end{code}
1238
1239 Strictness: we snaffle the info out of the IdInfo.
1240
1241 \begin{code}
1242 getIdStrictness :: Id -> StrictnessInfo Id
1243
1244 getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
1245
1246 addIdStrictness :: Id -> StrictnessInfo Id -> Id
1247 addIdStrictness (Id u n ty details prags info) strict_info
1248   = Id u n ty details prags (info `addStrictnessInfo` strict_info)
1249 \end{code}
1250
1251 %************************************************************************
1252 %*                                                                      *
1253 \subsection[Id-comparison]{Comparison functions for @Id@s}
1254 %*                                                                      *
1255 %************************************************************************
1256
1257 Comparison: equality and ordering---this stuff gets {\em hammered}.
1258
1259 \begin{code}
1260 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1261 -- short and very sweet
1262 \end{code}
1263
1264 \begin{code}
1265 instance Ord3 (GenId ty) where
1266     cmp = cmpId
1267
1268 instance Eq (GenId ty) where
1269     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
1270     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True  }
1271
1272 instance Ord (GenId ty) where
1273     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1274     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1275     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1276     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1277     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1278 \end{code}
1279
1280 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1281 account when comparing two data constructors. We need to do this
1282 because a specialised data constructor has the same Unique as its
1283 unspecialised counterpart.
1284
1285 \begin{code}
1286 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1287
1288 cmpId_withSpecDataCon id1 id2
1289   | eq_ids && isDataCon id1 && isDataCon id2
1290   = cmpEqDataCon id1 id2
1291
1292   | otherwise
1293   = cmp_ids
1294   where
1295     cmp_ids = cmpId id1 id2
1296     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1297
1298 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1299   = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1300
1301 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1302 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1303 cmpEqDataCon _                             _ = EQ_
1304 \end{code}
1305
1306 %************************************************************************
1307 %*                                                                      *
1308 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1309 %*                                                                      *
1310 %************************************************************************
1311
1312 \begin{code}
1313 instance Outputable ty => Outputable (GenId ty) where
1314     ppr sty id = pprId sty id
1315
1316 -- and a SPECIALIZEd one:
1317 instance Outputable {-Id, i.e.:-}(GenId Type) where
1318     ppr sty id = pprId sty id
1319
1320 showId :: PprStyle -> Id -> String
1321 showId sty id = ppShow 80 (pprId sty id)
1322 \end{code}
1323
1324 Default printing code (not used for interfaces):
1325 \begin{code}
1326 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1327
1328 pprId sty (Id u n _ _ _ _) = ppr sty n
1329   -- WDP 96/05/06: We can re-elaborate this as we go along...
1330 \end{code}
1331
1332 \begin{code}
1333 idUnique (Id u _ _ _ _ _) = u
1334
1335 instance Uniquable (GenId ty) where
1336     uniqueOf = idUnique
1337
1338 instance NamedThing (GenId ty) where
1339     getName this_id@(Id u n _ details _ _) = n
1340 \end{code}
1341
1342 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1343 the @Uniques@ out of local @Ids@ given to it.
1344
1345 %************************************************************************
1346 %*                                                                      *
1347 \subsection{@IdEnv@s and @IdSet@s}
1348 %*                                                                      *
1349 %************************************************************************
1350
1351 \begin{code}
1352 type IdEnv elt = UniqFM elt
1353
1354 nullIdEnv         :: IdEnv a
1355
1356 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1357 unitIdEnv         :: GenId ty -> a -> IdEnv a
1358 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
1359 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
1360 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1361
1362 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
1363 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
1364 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1365 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
1366 modifyIdEnv       :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
1367 rngIdEnv          :: IdEnv a -> [a]
1368
1369 isNullIdEnv       :: IdEnv a -> Bool
1370 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
1371 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1372 \end{code}
1373
1374 \begin{code}
1375 addOneToIdEnv    = addToUFM
1376 combineIdEnvs    = plusUFM_C
1377 delManyFromIdEnv = delListFromUFM
1378 delOneFromIdEnv  = delFromUFM
1379 growIdEnv        = plusUFM
1380 lookupIdEnv      = lookupUFM
1381 mapIdEnv         = mapUFM
1382 mkIdEnv          = listToUFM
1383 nullIdEnv        = emptyUFM
1384 rngIdEnv         = eltsUFM
1385 unitIdEnv        = unitUFM
1386
1387 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
1388 isNullIdEnv       env       = sizeUFM env == 0
1389 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
1390
1391 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1392 -- modify function, and put it back.
1393
1394 modifyIdEnv mangle_fn env key
1395   = case (lookupIdEnv env key) of
1396       Nothing -> env
1397       Just xx -> addOneToIdEnv env key (mangle_fn xx)
1398
1399 modifyIdEnv_Directly mangle_fn env key
1400   = case (lookupUFM_Directly env key) of
1401       Nothing -> env
1402       Just xx -> addToUFM_Directly env key (mangle_fn xx)
1403 \end{code}
1404
1405 \begin{code}
1406 type GenIdSet ty = UniqSet (GenId ty)
1407 type IdSet       = UniqSet (GenId Type)
1408
1409 emptyIdSet      :: GenIdSet ty
1410 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1411 unionIdSets     :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1412 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1413 idSetToList     :: GenIdSet ty -> [GenId ty]
1414 unitIdSet       :: GenId ty -> GenIdSet ty
1415 addOneToIdSet   :: GenIdSet ty -> GenId ty -> GenIdSet ty
1416 elementOfIdSet  :: GenId ty -> GenIdSet ty -> Bool
1417 minusIdSet      :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1418 isEmptyIdSet    :: GenIdSet ty -> Bool
1419 mkIdSet         :: [GenId ty] -> GenIdSet ty
1420
1421 emptyIdSet      = emptyUniqSet
1422 unitIdSet       = unitUniqSet
1423 addOneToIdSet   = addOneToUniqSet
1424 intersectIdSets = intersectUniqSets
1425 unionIdSets     = unionUniqSets
1426 unionManyIdSets = unionManyUniqSets
1427 idSetToList     = uniqSetToList
1428 elementOfIdSet  = elementOfUniqSet
1429 minusIdSet      = minusUniqSet
1430 isEmptyIdSet    = isEmptyUniqSet
1431 mkIdSet         = mkUniqSet
1432 \end{code}
1433
1434 \begin{code}
1435 addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id
1436
1437 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1438   = case (lookupUFM_Directly idenv u) of
1439       Just xx -> trace "addId: already in map!" $
1440                  (nenv, xx)
1441       Nothing ->
1442         if toplevelishId id then
1443             trace "addId: can't add toplevelish!" $
1444             (nenv, id)
1445         else -- alloc a new unique for this guy
1446              -- and add an entry in the idenv
1447              -- NB: *** KNOT-TYING ***
1448             let
1449                 nenv_plus_id    = NmbrEnv (incrUnique ui) ut uu
1450                                           (addToUFM_Directly idenv u new_id)
1451                                           tvenv uvenv
1452
1453                 (nenv2, new_ty)  = nmbrType     ty  nenv_plus_id
1454                 (nenv3, new_det) = nmbr_details det nenv2
1455
1456                 new_id = Id ui n new_ty new_det prag info
1457             in
1458             (nenv3, new_id)
1459
1460 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1461   = case (lookupUFM_Directly idenv u) of
1462       Just xx -> (nenv, xx)
1463       Nothing ->
1464         if not (toplevelishId id) then
1465             trace "nmbrId: lookup failed" $
1466             (nenv, id)
1467         else
1468             let
1469                 (nenv2, new_ty)  = nmbrType     ty  nenv
1470                 (nenv3, new_det) = nmbr_details det nenv2
1471
1472                 new_id = Id u n new_ty new_det prag info
1473             in
1474             (nenv3, new_id)
1475
1476     -- used when renumbering TyCons to produce data decls...
1477 nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
1478   = (nenv, id) -- nothing to do for tuples
1479
1480 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)
1481   = case (lookupUFM_Directly idenv u) of
1482       Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
1483       Nothing ->
1484         let
1485             (nenv2, new_fields)  = (mapNmbr nmbrField  fields)  nenv
1486             (nenv3, new_arg_tys) = (mapNmbr nmbrType   arg_tys) nenv2
1487
1488             new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
1489             new_id  = Id u n (bottom "ty") new_det prag info
1490         in
1491         (nenv3, new_id)
1492   where
1493     bottom msg = panic ("nmbrDataCon"++msg)
1494
1495 ------------
1496 nmbr_details :: IdDetails -> NmbrM IdDetails
1497
1498 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1499   = mapNmbr nmbrTyVar  tvs      `thenNmbr` \ new_tvs ->
1500     mapNmbr nmbrField  fields   `thenNmbr` \ new_fields ->
1501     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
1502     mapNmbr nmbrType   arg_tys  `thenNmbr` \ new_arg_tys ->
1503     returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1504   where
1505     nmbr_theta (c,t)
1506       = --nmbrClass c   `thenNmbr` \ new_c ->
1507         nmbrType  t     `thenNmbr` \ new_t ->
1508         returnNmbr (c, new_t)
1509
1510     -- ToDo:add more cases as needed
1511 nmbr_details other_details = returnNmbr other_details
1512
1513 ------------
1514 nmbrField (FieldLabel n ty tag)
1515   = nmbrType ty `thenNmbr` \ new_ty ->
1516     returnNmbr (FieldLabel n new_ty tag)
1517 \end{code}