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