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