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