ghc/compiler/basicTypes/Id.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Id]{@Ids@: Value and constructor identifiers}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Id (
  10         Id, -- abstract
  11         IdInfo, -- re-exporting
  12         ConTag(..), DictVar(..), DictFun(..), DataCon(..),
  13
  14         -- CONSTRUCTION
  15         mkSysLocal, mkUserLocal,
  16         mkSpecPragmaId,
  17         mkSpecId, mkSameSpecCon,
  18         selectIdInfoForSpecId,
  19         mkTemplateLocals,
  20         mkImported, mkPreludeId,
  21         mkDataCon, mkTupleCon,
  22         mkIdWithNewUniq,
  23         mkClassOpId, mkSuperDictSelId, mkDefaultMethodId,
  24         mkConstMethodId, mkInstId,
  25 #ifdef DPH
  26         mkProcessorCon,
  27         mkPodId,
  28 #endif {- Data Parallel Haskell -}
  29
  30         updateIdType,
  31         mkId, mkDictFunId,
  32         mkWorkerId,
  33         localiseId,
  34
  35         -- DESTRUCTION
  36         getIdUniType,
  37         getInstNamePieces, getIdInfo, replaceIdInfo,
  38         getIdKind, getInstIdModule,
  39         getMentionedTyConsAndClassesFromId,
  40         getDataConTag,
  41         getDataConSig, getInstantiatedDataConSig,
  42         getDataConTyCon, -- UNUSED: getDataConFamily,
  43 #ifdef USE_SEMANTIQUE_STRANAL
  44         getDataConDeps,
  45 #endif
  46
  47         -- PREDICATES
  48         isDataCon, isTupleCon, isNullaryDataCon,
  49         isSpecId_maybe, isSpecPragmaId_maybe,
  50         toplevelishId, externallyVisibleId,
  51         isTopLevId, isWorkerId, isWrapperId,
  52         isImportedId, isSysLocalId,
  53         isBottomingId,
  54         isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
  55         isDictFunId, isInstId_maybe, isConstMethodId_maybe,
  56 #ifdef DPH
  57         isInventedTopLevId,
  58         isProcessorCon,
  59 #endif {- Data Parallel Haskell -}
  60         eqId, cmpId,
  61         cmpId_withSpecDataCon,
  62         myWrapperMaybe,
  63         whatsMentionedInId,
  64         unfoldingUnfriendlyId,  -- ToDo: rm, eventually
  65         idWantsToBeINLINEd,
  66 --      dataConMentionsNonPreludeTyCon,
  67
  68         -- SUBSTITUTION
  69         applySubstToId, applyTypeEnvToId,
  70 -- not exported:        apply_to_Id, -- please don't use this, generally
  71
  72         -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
  73         getIdArity, getDataConArity, addIdArity,
  74         getIdDemandInfo, addIdDemandInfo,
  75         getIdSpecialisation, addIdSpecialisation,
  76         getIdStrictness, addIdStrictness,
  77         getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding,
  78         getIdUpdateInfo, addIdUpdateInfo,
  79         getIdArgUsageInfo, addIdArgUsageInfo,
  80         getIdFBTypeInfo, addIdFBTypeInfo,
  81         -- don't export the types, lest OptIdInfo be dragged in!
  82
  83         -- MISCELLANEOUS
  84         unlocaliseId,
  85         fIRST_TAG,
  86         showId,
  87         pprIdInUnfolding,
  88
  89         -- and to make the interface self-sufficient...
  90         Class, ClassOp, GlobalSwitch, Inst, Maybe, Name,
  91         FullName, PprStyle, PrettyRep,
  92         PrimKind, SrcLoc, Pretty(..), Subst, UnfoldingDetails,
  93         TyCon, TyVar, TyVarTemplate, TauType(..), UniType, Unique,
  94         UniqueSupply, Arity(..), ThetaType(..),
  95         TypeEnv(..), UniqFM, InstTemplate, Bag,
  96         SpecEnv, nullSpecEnv, SpecInfo,
  97
  98         -- and to make sure pragmas work...
  99         IdDetails  -- from this module, abstract
 100         IF_ATTACK_PRAGMAS(COMMA getMentionedTyConsAndClassesFromUniType)
 101         IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
 102         IF_ATTACK_PRAGMAS(COMMA getInfo_UF)
 103
 104 #ifndef __GLASGOW_HASKELL__
 105         , TAG_
 106 #endif
 107     ) where
 108
 109 IMPORT_Trace            -- ToDo: rm (debugging only)
 110
 111 import AbsPrel          ( PrimOp, PrimKind, mkFunTy, nilDataCon, pRELUDE_BUILTIN
 112                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
 113                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
 114 #ifdef DPH
 115                           , mkPodNTy, mkPodizedPodNTy
 116 #endif {- Data Parallel Haskell -}
 117                         )
 118
 119 import AbsUniType
 120 import Bag
 121 import CLabelInfo       ( identToC, cSEP )
 122 import CmdLineOpts      ( GlobalSwitch(..) )
 123 import IdEnv            -- ( nullIdEnv, IdEnv )
 124 import IdInfo           -- piles of it
 125 import Inst             -- lots of things
 126 import Maybes           ( maybeToBool, Maybe(..) )
 127 import Name             ( Name(..) )
 128 import NameTypes
 129 import Outputable
 130 import Pretty           -- for pretty-printing
 131 import SrcLoc
 132 import Subst            ( applySubstToTy )       -- PRETTY GRIMY TO LOOK IN HERE
 133 import PlainCore
 134 import PrelFuns         ( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
 135 import UniqFM
 136 import UniqSet
 137 import Unique
 138 import Util
 139 #ifdef DPH
 140 IMPORT_Trace
 141 import PodizeCore       ( podizeTemplateExpr )
 142 import PodInfoTree      ( infoTypeNumToMask )
 143 #endif {- Data Parallel Haskell -}
 144 \end{code}
 145
 146 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 147 follow.
 148
 149 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
 150 @UniType@, and an @IdInfo@ (non-essential info about it, e.g.,
 151 strictness).  The essential info about different kinds of @Ids@ is
 152 in its @IdDetails@.
 153
 154 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 155
 156 \begin{code}
 157 data Id = Id    Unique          -- key for fast comparison
 158                 UniType         -- Id's type; used all the time;
 159                 IdInfo          -- non-essential info about this Id;
 160                 IdDetails       -- stuff about individual kinds of Ids.
 161
 162 data IdDetails
 163
 164   ---------------- Local values
 165
 166   = LocalId     ShortName       -- mentioned by the user
 167                 Bool            -- True <=> no free type vars
 168
 169   | SysLocalId  ShortName       -- made up by the compiler
 170                 Bool            -- as for LocalId
 171
 172   | SpecPragmaId ShortName      -- introduced by the compiler
 173                 (Maybe SpecInfo)-- for explicit specid in pragma
 174                 Bool            -- as for LocalId
 175
 176   ---------------- Global values
 177
 178   | ImportedId  FullName        -- Id imported from an interface
 179
 180   | PreludeId   FullName        -- things < Prelude that compiler "knows" about
 181
 182   | TopLevId    FullName        -- Top-level in the orig source pgm
 183                                 -- (not moved there by transformations).
 184
 185         -- a TopLevId's type may contain free type variables, if
 186         -- the monomorphism restriction applies.
 187
 188   ---------------- Data constructors
 189
 190   | DataConId   FullName
 191                 ConTag
 192                 -- cached pieces of the type:
 193                 [TyVarTemplate] [(Class,UniType)] [UniType] TyCon
 194                 -- the type is:
 195                 -- forall tyvars . theta_ty =>
 196                 --    unitype_1 -> ... -> unitype_n -> tycon tyvars
 197                 --
 198                 -- "type ThetaType  = [(Class, UniType)]"
 199
 200                 -- The [TyVarTemplate] is in the same order as the args of the
 201                 -- TyCon for the constructor
 202
 203   | TupleConId  Int             -- Its arity
 204
 205 #ifdef DPH
 206   | ProcessorCon Int            -- Its arity
 207 #endif {- Data Parallel Haskell -}
 208
 209   ---------------- Things to do with overloading
 210
 211   | SuperDictSelId              -- Selector for superclass dictionary
 212                 Class           -- The class (input dict)
 213                 Class           -- The superclass (result dict)
 214
 215   | ClassOpId   Class           -- An overloaded class operation, with
 216                                 -- a fully polymorphic type.  Its code
 217                                 -- just selects a method from the
 218                                 -- dictionary.  The class.
 219                 ClassOp         -- The operation
 220
 221         -- NB: The IdInfo for a ClassOpId has all the info about its
 222         -- related "constant method Ids", which are just
 223         -- specialisations of this general one.
 224
 225   | DefaultMethodId             -- Default method for a particular class op
 226                 Class           -- same class, <blah-blah> info as ClassOpId
 227                 ClassOp         -- (surprise, surprise)
 228                 Bool            -- True <=> I *know* this default method Id
 229                                 -- is a generated one that just says
 230                                 -- `error "No default method for <op>"'.
 231 \end{code}
 232
 233 DictFunIds are generated from instance decls.
 234 \begin{verbatim}
 235         class Foo a where
 236           op :: a -> a -> Bool
 237
 238         instance Foo a => Foo [a] where
 239           op = ...
 240 \end{verbatim}
 241 generates the dict fun id decl
 242 \begin{verbatim}
 243         dfun.Foo.[*] = \d -> ...
 244 \end{verbatim}
 245 The dfun id is uniquely named by the (class, type) pair.  Notice, it
 246 isn't a (class,tycon) pair any more, because we may get manually or
 247 automatically generated specialisations of the instance decl:
 248 \begin{verbatim}
 249         instance Foo [Int] where
 250           op = ...
 251 \end{verbatim}
 252 generates
 253 \begin{verbatim}
 254         dfun.Foo.[Int] = ...
 255 \end{verbatim}
 256 The type variables in the name are irrelevant; we print them as stars.
 257
 258 \begin{code}
 259   | DictFunId   Class           -- A DictFun is uniquely identified
 260                 UniType         -- by its class and type; this type has free type vars,
 261                                 -- whose identity is irrelevant.  Eg Class = Eq
 262                                 --                                   Type  = Tree a
 263                                 -- The "a" is irrelevant.  As it is too painful to
 264                                 -- actually do comparisons that way, we kindly supply
 265                                 -- a Unique for that purpose.
 266                 Bool            -- True <=> from an instance decl in this mod
 267                 FAST_STRING     -- module where instance came from
 268 \end{code}
 269
 270 Constant method ids are generated from instance decls where
 271 there is no context; that is, no dictionaries are needed to
 272 construct the method.  Example
 273 \begin{verbatim}
 274         instance Foo Int where
 275           op = ...
 276 \end{verbatim}
 277 Then we get a constant method
 278 \begin{verbatim}
 279         Foo.op.Int = ...
 280 \end{verbatim}
 281
 282 It is possible, albeit unusual, to have a constant method
 283 for an instance decl which has type vars:
 284 \begin{verbatim}
 285         instance Foo [a] where
 286           op []     ys = True
 287           op (x:xs) ys = False
 288 \end{verbatim}
 289 We get the constant method
 290 \begin{verbatim}
 291         Foo.op.[*] = ...
 292 \end{verbatim}
 293 So a constant method is identified by a class/op/type triple.
 294 The type variables in the type are irrelevant.
 295
 296 \begin{code}
 297   | ConstMethodId               -- A method which depends only on the type of the
 298                                 -- instance, and not on any further dictionaries etc.
 299                 Class           -- Uniquely identified by:
 300                 UniType         -- (class, type, classop) triple
 301                 ClassOp
 302                 Bool            -- True <=> from an instance decl in this mod
 303                 FAST_STRING     -- module where instance came from
 304
 305   | InstId      Inst            -- An instance of a dictionary, class operation,
 306                                 -- or overloaded value
 307
 308   | SpecId                      -- A specialisation of another Id
 309                 Id              -- Id of which this is a specialisation
 310                 [Maybe UniType] -- Types at which it is specialised;
 311                                 -- A "Nothing" says this type ain't relevant.
 312                 Bool            -- True <=> no free type vars; it's not enough
 313                                 -- to know about the unspec version, because
 314                                 -- we may specialise to a type w/ free tyvars
 315                                 -- (i.e., in one of the "Maybe UniType" dudes).
 316
 317   | WorkerId                    -- A "worker" for some other Id
 318                 Id              -- Id for which this is a worker
 319
 320 #ifdef DPH
 321   | PodId       Int             -- The dimension of the PODs context
 322                 Int             -- Which specialisation of InfoType is
 323                                 -- bind. ToDo(hilly): Int is a little messy
 324                                 -- and has a restricted range---change.
 325                 Id              -- One of the aboves Ids.
 326 #endif {- Data Parallel Haskell -}
 327
 328 type ConTag     = Int
 329 type DictVar    = Id
 330 type DictFun    = Id
 331 type DataCon    = Id
 332 \end{code}
 333
 334 For Ids whose names must be known/deducible in other modules, we have
 335 to conjure up their worker's names (and their worker's worker's
 336 names... etc) in a known systematic way.
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[Id-documentation]{Documentation}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 [A BIT DATED [WDP]]
 345
 346 The @Id@ datatype describes {\em values}.  The basic things we want to
 347 know: (1)~a value's {\em type} (@getIdUniType@ is a very common
 348 operation in the compiler); and (2)~what ``flavour'' of value it might
 349 be---for example, it can be terribly useful to know that a value is a
 350 class method.
 351
 352 \begin{description}
 353 %----------------------------------------------------------------------
 354 \item[@DataConId@:] For the data constructors declared by a @data@
 355 declaration.  Their type is kept in {\em two} forms---as a regular
 356 @UniType@ (in the usual place), and also in its constituent pieces (in
 357 the ``details''). We are frequently interested in those pieces.
 358
 359 %----------------------------------------------------------------------
 360 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
 361 the infinite family of tuples.
 362
 363 %----------------------------------------------------------------------
 364 \item[@ImportedId@:] These are values defined outside this module.
 365 {\em Everything} we want to know about them must be stored here (or in
 366 their @IdInfo@).
 367
 368 %----------------------------------------------------------------------
 369 \item[@PreludeId@:] ToDo
 370
 371 %----------------------------------------------------------------------
 372 \item[@TopLevId@:] These are values defined at the top-level in this
 373 module; i.e., those which {\em might} be exported (hence, a
 374 @FullName@).  It does {\em not} include those which are moved to the
 375 top-level through program transformations.
 376
 377 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
 378 Theoretically, they could be floated inwards, but there's no known
 379 advantage in doing so.  This way, we can keep them with the same
 380 @Unique@ throughout (no cloning), and, in general, we don't have to be
 381 so paranoid about them.
 382
 383 In particular, we had the following problem generating an interface:
 384 We have to ``stitch together'' info (1)~from the typechecker-produced
 385 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
 386 what arities].  If the @Uniques@ on the @TopLevIds@ can {\em change}
 387 between (1) and (2), you're sunk!
 388
 389 %----------------------------------------------------------------------
 390 \item[@ClassOpId@:] A selector from a dictionary; it may select either
 391 a method or a dictionary for one of the class's superclasses.
 392
 393 %----------------------------------------------------------------------
 394 \item[@DictFunId@:]
 395
 396 @mkDictFunId [a,b..] theta C T@ is the function derived from the
 397 instance declaration
 398
 399         instance theta => C (T a b ..) where
 400                 ...
 401
 402 It builds function @Id@ which maps dictionaries for theta,
 403 to a dictionary for C (T a b ..).
 404
 405 *Note* that with the ``Mark Jones optimisation'', the theta may
 406 include dictionaries for the immediate superclasses of C at the type
 407 (T a b ..).
 408
 409 %----------------------------------------------------------------------
 410 \item[@InstId@:]
 411
 412 %----------------------------------------------------------------------
 413 \item[@SpecId@:]
 414
 415 %----------------------------------------------------------------------
 416 \item[@WorkerId@:]
 417
 418 %----------------------------------------------------------------------
 419 \item[@LocalId@:] A purely-local value, e.g., a function argument,
 420 something defined in a @where@ clauses, ... --- but which appears in
 421 the original program text.
 422
 423 %----------------------------------------------------------------------
 424 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
 425 the original program text; these are introduced by the compiler in
 426 doing its thing.
 427
 428 %----------------------------------------------------------------------
 429 \item[@SpecPragmaId@:] Introduced by the compiler to record
 430 Specialisation pragmas. It is dead code which MUST NOT be removed
 431 before specialisation.
 432 \end{description}
 433
 434 Further remarks:
 435 \begin{enumerate}
 436 %----------------------------------------------------------------------
 437 \item
 438
 439 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
 440 @ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 441 properties:
 442 \begin{itemize}
 443 \item
 444 They have no free type variables, so if you are making a
 445 type-variable substitution you don't need to look inside them.
 446 \item
 447 They are constants, so they are not free variables.  (When the STG
 448 machine makes a closure, it puts all the free variables in the
 449 closure; the above are not required.)
 450 \end{itemize}
 451 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
 452 properties, but they may not.
 453 \end{enumerate}
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458 \subsection[Id-general-funs]{General @Id@-related functions}
 459 %*                                                                      *
 460 %************************************************************************
 461
 462 \begin{code}
 463 isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True
 464 isDataCon (Id _ _ _ (TupleConId _))          = True
 465 isDataCon (Id _ _ _ (SpecId unspec _ _))     = isDataCon unspec
 466 #ifdef DPH
 467 isDataCon (ProcessorCon _ _)          = True
 468 isDataCon (PodId _ _ id )             = isDataCon id
 469 #endif {- Data Parallel Haskell -}
 470 isDataCon other                       = False
 471
 472 isTupleCon (Id _ _ _ (TupleConId _))        = True
 473 isTupleCon (Id _ _ _ (SpecId unspec _ _))   = isTupleCon unspec
 474 #ifdef DPH
 475 isTupleCon (PodId _ _ id)       = isTupleCon id
 476 #endif {- Data Parallel Haskell -}
 477 isTupleCon other                = False
 478
 479 isNullaryDataCon data_con
 480   =  isDataCon data_con
 481   && (case arityMaybe (getIdArity data_con) of
 482         Just a -> a == 0
 483         _      -> panic "isNullaryDataCon")
 484
 485 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _))
 486   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 487     Just (unspec, ty_maybes)
 488 isSpecId_maybe other_id
 489   = Nothing
 490
 491 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId _ specinfo _))
 492   = Just specinfo
 493 isSpecPragmaId_maybe other_id
 494   = Nothing
 495
 496 #ifdef DPH
 497 isProcessorCon (ProcessorCon _ _) = True
 498 isProcessorCon (PodId _ _ id)     = isProcessorCon id
 499 isProcessorCon other              = False
 500 #endif {- Data Parallel Haskell -}
 501 \end{code}
 502
 503 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
 504 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
 505 defined at top level (returns @True@).  This is used to decide whether
 506 the @Id@ is a candidate free variable.  NB: you are only {\em sure}
 507 about something if it returns @True@!
 508
 509 \begin{code}
 510 toplevelishId       :: Id -> Bool
 511 idHasNoFreeTyVars   :: Id -> Bool
 512
 513 toplevelishId (Id _ _ _ details)
 514   = chk details
 515   where
 516     chk (DataConId _ _ _ _ _ _) = True
 517     chk (TupleConId _)          = True
 518     chk (ImportedId _)          = True
 519     chk (PreludeId  _)          = True
 520     chk (TopLevId   _)          = True  -- NB: see notes
 521     chk (SuperDictSelId _ _)    = True
 522     chk (ClassOpId _ _)         = True
 523     chk (DefaultMethodId _ _ _) = True
 524     chk (DictFunId     _ _ _ _) = True
 525     chk (ConstMethodId _ _ _ _ _) = True
 526     chk (SpecId unspec _ _)     = toplevelishId unspec
 527                                   -- depends what the unspecialised thing is
 528     chk (WorkerId unwrkr)       = toplevelishId unwrkr
 529     chk (InstId _)              = False -- these are local
 530     chk (LocalId      _ _)      = False
 531     chk (SysLocalId   _ _)      = False
 532     chk (SpecPragmaId _ _ _)    = False
 533 #ifdef DPH
 534     chk (ProcessorCon _ _)      = True
 535     chk (PodId _ _ id)          = toplevelishId id
 536 #endif {- Data Parallel Haskell -}
 537
 538 idHasNoFreeTyVars (Id _ _ info details)
 539   = chk details
 540   where
 541     chk (DataConId _ _ _ _ _ _) = True
 542     chk (TupleConId _)          = True
 543     chk (ImportedId _)          = True
 544     chk (PreludeId  _)          = True
 545     chk (TopLevId   _)          = True
 546     chk (SuperDictSelId _ _)    = True
 547     chk (ClassOpId _ _)         = True
 548     chk (DefaultMethodId _ _ _) = True
 549     chk (DictFunId     _ _ _ _) = True
 550     chk (ConstMethodId _ _ _ _ _) = True
 551     chk (WorkerId unwrkr)       = idHasNoFreeTyVars unwrkr
 552     chk (InstId _)                    = False   -- these are local
 553     chk (SpecId _     _   no_free_tvs) = no_free_tvs
 554     chk (LocalId      _   no_free_tvs) = no_free_tvs
 555     chk (SysLocalId   _   no_free_tvs) = no_free_tvs
 556     chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
 557 #ifdef DPH
 558     chk (ProcessorCon _ _)      = True
 559     chk (PodId _ _ id)          = idHasNoFreeTyVars id
 560 #endif {- Data Parallel Haskell -}
 561 \end{code}
 562
 563 \begin{code}
 564 isTopLevId (Id _ _ _ (TopLevId _)) = True
 565 #ifdef DPH
 566 isTopLevId (PodId _ _ id)       = isTopLevId id
 567 #endif {- Data Parallel Haskell -}
 568 isTopLevId other                = False
 569
 570 -- an "invented" one is a top-level Id, must be globally visible, etc.,
 571 -- but it's slightly different in that it was "conjured up".
 572 -- This handles workers fine, but may need refinement for other
 573 -- conjured-up things (e.g., specializations)
 574 -- NB: Only used in DPH now (93/08/20)
 575
 576 #ifdef DPH
 577 ToDo: DPH
 578 isInventedTopLevId (TopLevId _ n _ _)   = isInventedFullName n
 579 isInventedTopLevId (SpecId _ _ _)       = True
 580 isInventedTopLevId (WorkerId _)         = True
 581 isInventedTopLevId (PodId _ _ id)       = isInventedTopLevId id
 582 isInventedTopLevId other                = False
 583 #endif {- Data Parallel Haskell -}
 584
 585 isImportedId (Id _ _ _ (ImportedId _))   = True
 586 #ifdef DPH
 587 isImportedId (PodId _ _ id)       = isImportedId id
 588 #endif {- Data Parallel Haskell -}
 589 isImportedId other                = False
 590
 591 isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info)
 592 #ifdef DPH
 593 isBottomingId (PodId _ _ id)      = isBottomingId id
 594 #endif {- Data Parallel Haskell -}
 595 --isBottomingId other             = False
 596
 597 isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True
 598 #ifdef DPH
 599 isSysLocalId (PodId _ _ id)     = isSysLocalId id
 600 #endif {- Data Parallel Haskell -}
 601 isSysLocalId other              = False
 602
 603 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True
 604 #ifdef DPH
 605 isSpecPragmaId (PodId _ _ id)   = isSpecPragmaId id
 606 #endif {- Data Parallel Haskell -}
 607 isSpecPragmaId other            = False
 608
 609 isClassOpId (Id _ _ _ (ClassOpId _ _)) = True
 610 isClassOpId _ = False
 611
 612 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err)
 613 #ifdef DPH
 614 isDefaultMethodId_maybe (PodId _ _ id)  = isDefaultMethodId_maybe id
 615 #endif {- Data Parallel Haskell -}
 616 isDefaultMethodId_maybe other           = Nothing
 617
 618 isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True
 619 #ifdef DPH
 620 isDictFunId (PodId _ _ id)              = isDictFunId id
 621 #endif {- Data Parallel Haskell -}
 622 isDictFunId other                       = False
 623
 624 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop)
 625 #ifdef DPH
 626 isConstMethodId_maybe (PodId _ _ id)    = isConstMethodId_maybe id
 627 #endif {- Data Parallel Haskell -}
 628 isConstMethodId_maybe other             = Nothing
 629
 630 isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst
 631 #ifdef DPH
 632 isInstId_maybe (PodId _ _ id)           = isInstId_maybe id
 633 #endif {- Data Parallel Haskell -}
 634 isInstId_maybe other_id                 = Nothing
 635
 636 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc)
 637 #ifdef DPH
 638 isSuperDictSelId_maybe (PodId _ _ id)   = isSuperDictSelId_maybe id
 639 #endif {- Data Parallel Haskell -}
 640 isSuperDictSelId_maybe other_id         = Nothing
 641
 642 isWorkerId (Id _ _ _ (WorkerId _)) = True
 643 #ifdef DPH
 644 isWorkerId (PodId _ _ id)           = isWorkerId id
 645 #endif {- Data Parallel Haskell -}
 646 isWorkerId other                    = False
 647
 648 isWrapperId id = workerExists (getIdStrictness id)
 649 \end{code}
 650
 651 \begin{code}
 652 pprIdInUnfolding :: IdSet -> Id -> Pretty
 653
 654 pprIdInUnfolding in_scopes v
 655   = let
 656         v_ty = getIdUniType v
 657     in
 658     -- local vars first:
 659     if v `elementOfUniqSet` in_scopes then
 660         pprUnique (getTheUnique v)
 661
 662     -- ubiquitous Ids with special syntax:
 663     else if v == nilDataCon then
 664         ppPStr SLIT("_NIL_")
 665     else if isTupleCon v then
 666         ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
 667
 668     -- ones to think about:
 669     else
 670         let
 671             (Id _ _ _ v_details) = v
 672         in
 673         case v_details of
 674             -- these ones must have been exported by their original module
 675           ImportedId   _ -> pp_full_name
 676           PreludeId    _ -> pp_full_name
 677
 678             -- these ones' exportedness checked later...
 679           TopLevId  _ -> pp_full_name
 680           DataConId _ _ _ _ _ _ -> pp_full_name
 681
 682             -- class-ish things: class already recorded as "mentioned"
 683           SuperDictSelId c sc
 684             -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
 685           ClassOpId c o
 686             -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
 687           DefaultMethodId c o _
 688             -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
 689
 690             -- instance-ish things: should we try to figure out
 691             -- *exactly* which extra instances have to be exported? (ToDo)
 692           DictFunId  c t _ _
 693             -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
 694           ConstMethodId c t o _ _
 695             -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
 696
 697           -- specialisations and workers
 698           SpecId unspec ty_maybes _
 699             -> let
 700                   pp = pprIdInUnfolding in_scopes unspec
 701                in
 702                ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
 703                         ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
 704                         ppRbrack]
 705
 706           WorkerId unwrkr
 707             -> let
 708                   pp = pprIdInUnfolding in_scopes unwrkr
 709                in
 710                ppBeside (ppPStr SLIT("_WRKR_ ")) pp
 711
 712           -- anything else? we're nae interested
 713           other_id -> panic "pprIdInUnfolding:mystery Id"
 714   where
 715     ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
 716
 717     pp_full_name
 718       = let
 719             (m_str, n_str) = getOrigName v
 720
 721             pp_n =
 722               if isAvarop n_str || isAconop n_str then
 723                   ppBesides [ppLparen, ppPStr n_str, ppRparen]
 724               else
 725                   ppPStr n_str
 726         in
 727         if fromPreludeCore v then
 728             pp_n
 729         else
 730             ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
 731
 732     pp_class :: Class -> Pretty
 733     pp_class_op :: ClassOp -> Pretty
 734     pp_type :: UniType -> Pretty
 735     pp_ty_maybe :: Maybe UniType -> Pretty
 736
 737     pp_class    clas = ppr ppr_Unfolding clas
 738     pp_class_op op   = ppr ppr_Unfolding op
 739
 740     pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
 741
 742     pp_ty_maybe Nothing  = ppPStr SLIT("_N_")
 743     pp_ty_maybe (Just t) = pp_type t
 744 \end{code}
 745
 746 @whatsMentionedInId@ ferrets out the types/classes/instances on which
 747 this @Id@ depends.  If this Id is to appear in an interface, then
 748 those entities had Jolly Well be in scope.  Someone else up the
 749 call-tree decides that.
 750
 751 \begin{code}
 752 whatsMentionedInId
 753         :: IdSet                            -- Ids known to be in scope
 754         -> Id                               -- Id being processed
 755         -> (Bag Id, Bag TyCon, Bag Class)   -- mentioned Ids/TyCons/etc.
 756
 757 whatsMentionedInId in_scopes v
 758   = let
 759         v_ty = getIdUniType v
 760
 761         (tycons, clss)
 762           = getMentionedTyConsAndClassesFromUniType v_ty
 763
 764         result0 id_bag = (id_bag, tycons, clss)
 765
 766         result1 ids tcs cs
 767           = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
 768              tcs `unionBags` tycons,
 769              cs  `unionBags` clss)
 770     in
 771     -- local vars first:
 772     if v `elementOfUniqSet` in_scopes then
 773         result0 emptyBag    -- v not added to "mentioned"
 774
 775     -- ones to think about:
 776     else
 777         let
 778             (Id _ _ _ v_details) = v
 779         in
 780         case v_details of
 781           -- specialisations and workers
 782           SpecId unspec ty_maybes _
 783             -> let
 784                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
 785                in
 786                result1 ids2 tcs2 cs2
 787
 788           WorkerId unwrkr
 789             -> let
 790                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
 791                in
 792                result1 ids2 tcs2 cs2
 793
 794           anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
 795 \end{code}
 796
 797 Tell them who my wrapper function is.
 798 \begin{code}
 799 myWrapperMaybe :: Id -> Maybe Id
 800
 801 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper)) = Just my_wrapper
 802 myWrapperMaybe other_id                         = Nothing
 803 \end{code}
 804
 805 \begin{code}
 806 unfoldingUnfriendlyId   -- return True iff it is definitely a bad
 807         :: Id           -- idea to export an unfolding that
 808         -> Bool         -- mentions this Id.  Reason: it cannot
 809                         -- possibly be seen in another module.
 810
 811 unfoldingUnfriendlyId id
 812   | not (externallyVisibleId id) -- that settles that...
 813   = True
 814
 815 unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
 816   = class_thing wrapper
 817   where
 818     -- "class thing": If we're going to use this worker Id in
 819     -- an interface, we *have* to be able to untangle the wrapper's
 820     -- strictness when reading it back in.  At the moment, this
 821     -- is not always possible: in precisely those cases where
 822     -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
 823
 824     class_thing (Id _ _ _ (SuperDictSelId _ _))    = True
 825     class_thing (Id _ _ _ (ClassOpId _ _))         = True
 826     class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
 827     class_thing other                              = False
 828
 829 unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
 830     -- a SPEC of a DictFunId can end up w/ gratuitous
 831     -- TyVar(Templates) in the i/face; only a problem
 832     -- if -fshow-pragma-name-errs; but we can do without the pain.
 833     -- A HACK in any case (WDP 94/05/02)
 834   = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
 835     naughty_DictFunId dfun
 836     --)
 837
 838 unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
 839   = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
 840     naughty_DictFunId dfun -- similar deal...
 841     --)
 842
 843 unfoldingUnfriendlyId other_id   = False -- is friendly in all other cases
 844
 845 naughty_DictFunId :: IdDetails -> Bool
 846     -- True <=> has a TyVar(Template) in the "type" part of its "name"
 847
 848 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
 849 naughty_DictFunId (DictFunId _ ty _ _)
 850   = not (isGroundTy ty)
 851 \end{code}
 852
 853 @externallyVisibleId@: is it true that another module might be
 854 able to ``see'' this Id?
 855
 856 We need the @toplevelishId@ check as well as @isExported@ for when we
 857 compile instance declarations in the prelude.  @DictFunIds@ are
 858 ``exported'' if either their class or tycon is exported, but, in
 859 compiling the prelude, the compiler may not recognise that as true.
 860
 861 \begin{code}
 862 externallyVisibleId :: Id -> Bool
 863
 864 externallyVisibleId id@(Id _ _ _ details)
 865   = if isLocallyDefined id then
 866         toplevelishId id && isExported id && not (weird_datacon details)
 867     else
 868         not (weird_tuplecon details)
 869         -- if visible here, it must be visible elsewhere, too.
 870   where
 871     -- If it's a DataCon, it's not enough to know it (meaning
 872     -- its TyCon) is exported; we need to know that it might
 873     -- be visible outside.  Consider:
 874     --
 875     --  data Foo a = Mumble | BigFoo a WeirdLocalType
 876     --
 877     -- We can't tell the outside world *anything* about Foo, because
 878     -- of WeirdLocalType; but we need to know this when asked if
 879     -- "Mumble" is externally visible...
 880
 881     weird_datacon (DataConId _ _ _ _ _ tycon)
 882       = maybeToBool (maybePurelyLocalTyCon tycon)
 883     weird_datacon not_a_datacon_therefore_not_weird = False
 884
 885     weird_tuplecon (TupleConId arity)
 886       = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
 887     weird_tuplecon _ = False
 888 \end{code}
 889
 890 \begin{code}
 891 idWantsToBeINLINEd :: Id -> Bool
 892
 893 idWantsToBeINLINEd id
 894   = case (getIdUnfolding id) of
 895       IWantToBeINLINEd _ -> True
 896       _ -> False
 897 \end{code}
 898
 899 For @unlocaliseId@: See the brief commentary in
 900 \tr{simplStg/SimplStg.lhs}.
 901
 902 \begin{code}
 903 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
 904
 905 unlocaliseId mod (Id u ty info (TopLevId fn))
 906   = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
 907
 908 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
 909   = --false?: ASSERT(no_ftvs)
 910     let
 911         full_name = unlocaliseShortName mod u sn
 912     in
 913     Just (Id u ty info (TopLevId full_name))
 914
 915 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
 916   = --false?: on PreludeGlaST: ASSERT(no_ftvs)
 917     let
 918         full_name = unlocaliseShortName mod u sn
 919     in
 920     Just (Id u ty info (TopLevId full_name))
 921
 922 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
 923   = case unlocalise_parent mod u unspec of
 924       Nothing -> Nothing
 925       Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
 926
 927 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
 928   = case unlocalise_parent mod u unwrkr of
 929       Nothing -> Nothing
 930       Just xx -> Just (Id u ty info (WorkerId xx))
 931
 932 unlocaliseId mod (Id u ty info (InstId inst))
 933   = Just (Id u ty info (TopLevId full_name))
 934         -- type might be wrong, but it hardly matters
 935         -- at this stage (just before printing C)  ToDo
 936   where
 937     name = let  (bit1:bits) = getInstNamePieces True inst  in
 938            _CONCAT_ (bit1 : [ _CONS_ '.'  b | b <- bits ])
 939
 940     full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc
 941
 942 #ifdef DPH
 943 unlocaliseId mod (PodId dim ity id)
 944   = case (unlocaliseId mod id) of
 945       Just id' -> Just (PodId dim ity id')
 946       Nothing  -> Nothing
 947 #endif {- Data Parallel Haskell -}
 948
 949 unlocaliseId mod other_id = Nothing
 950
 951 --------------------
 952 -- we have to be Very Careful for workers/specs of
 953 -- local functions!
 954
 955 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
 956   = --false?: ASSERT(no_ftvs)
 957     let
 958         full_name = unlocaliseShortName mod uniq sn
 959     in
 960     Just (Id uniq ty info (TopLevId full_name))
 961
 962 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
 963   = --false?: ASSERT(no_ftvs)
 964     let
 965         full_name = unlocaliseShortName mod uniq sn
 966     in
 967     Just (Id uniq ty info (TopLevId full_name))
 968
 969 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
 970   -- we're OK otherwise
 971 \end{code}
 972
 973 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
 974 `Top-levelish Ids'' cannot have any free type variables, so applying
 975 the type-env cannot have any effect.  (NB: checked in CoreLint?)
 976
 977 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 978 former ``should be'' the usual crunch point.
 979
 980 \begin{code}
 981 applyTypeEnvToId :: TypeEnv -> Id -> Id
 982
 983 applyTypeEnvToId type_env id@(Id u ty info details)
 984   | idHasNoFreeTyVars id
 985   = id
 986   | otherwise
 987   = apply_to_Id ( \ ty ->
 988         applyTypeEnvToTy type_env ty
 989     ) id
 990 \end{code}
 991
 992 \begin{code}
 993 apply_to_Id :: (UniType -> UniType)
 994             -> Id
 995             -> Id
 996
 997 apply_to_Id ty_fn (Id u ty info details)
 998   = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
 999   where
1000     apply_to_details (InstId inst)
1001       = let
1002             new_inst = apply_to_Inst ty_fn inst
1003         in
1004         InstId new_inst
1005
1006     apply_to_details (SpecId unspec ty_maybes no_ftvs)
1007       = let
1008             new_unspec = apply_to_Id ty_fn unspec
1009             new_maybes = map apply_to_maybe ty_maybes
1010         in
1011         SpecId new_unspec new_maybes no_ftvs
1012         -- ToDo: recalc no_ftvs????
1013       where
1014         apply_to_maybe Nothing   = Nothing
1015         apply_to_maybe (Just ty) = Just (ty_fn ty)
1016
1017     apply_to_details (WorkerId unwrkr)
1018       = let
1019             new_unwrkr = apply_to_Id ty_fn unwrkr
1020         in
1021         WorkerId new_unwrkr
1022
1023 #ifdef DPH
1024     apply_to_details (PodId d ity id )
1025       = PodId d ity (apply_to_Id ty_fn id)
1026 #endif {- Data Parallel Haskell -}
1027
1028     apply_to_details other = other
1029 \end{code}
1030
1031 Sadly, I don't think the one using the magic typechecker substitution
1032 can be done with @apply_to_Id@.  Here we go....
1033
1034 Strictness is very important here.  We can't leave behind thunks
1035 with pointers to the substitution: it {\em must} be single-threaded.
1036
1037 \begin{code}
1038 applySubstToId :: Subst -> Id -> (Subst, Id)
1039
1040 applySubstToId subst id@(Id u ty info details)
1041   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
1042   -- because, in the typechecker, we are still
1043   -- *concocting* the types.
1044   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
1045     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
1046     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
1047     (s4, Id u new_ty new_info new_details) }}}
1048   where
1049     apply_to_details subst _ (InstId inst)
1050       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
1051         (s2, InstId new_inst) }
1052
1053     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
1054       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
1055         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
1056         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
1057         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
1058       where
1059         apply_to_maybe subst Nothing   = (subst, Nothing)
1060         apply_to_maybe subst (Just ty)
1061           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
1062             (s2, Just new_ty) }
1063
1064     apply_to_details subst _ (WorkerId unwrkr)
1065       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
1066         (s2, WorkerId new_unwrkr) }
1067
1068     apply_to_details subst _ other = (subst, other)
1069
1070 #ifdef DPH
1071 applySubstToId (PodId d ity id )
1072   = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id))
1073 #endif {- Data Parallel Haskell -}
1074 \end{code}
1075
1076 \begin{code}
1077 getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING]
1078
1079 getIdNamePieces show_uniqs (Id u ty info details)
1080   = case details of
1081       DataConId n _ _ _ _ _ ->
1082         case (getOrigName n) of { (mod, name) ->
1083         if fromPrelude mod then [name] else [mod, name] }
1084
1085       TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))]
1086
1087       ImportedId  n -> get_fullname_pieces n
1088       PreludeId   n -> get_fullname_pieces n
1089       TopLevId    n -> get_fullname_pieces n
1090
1091       SuperDictSelId c sc ->
1092         case (getOrigName c)    of { (c_mod, c_name) ->
1093         case (getOrigName sc)   of { (sc_mod, sc_name) ->
1094         let
1095             c_bits = if fromPreludeCore c
1096                      then [c_name]
1097                      else [c_mod, c_name]
1098
1099             sc_bits= if fromPreludeCore sc
1100                      then [sc_name]
1101                      else [sc_mod, sc_name]
1102         in
1103         [SLIT("sdsel")] ++ c_bits ++ sc_bits  }}
1104
1105       ClassOpId clas op ->
1106         case (getOrigName clas) of { (c_mod, c_name) ->
1107         case (getClassOpString op)      of { op_name ->
1108         if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
1109         } }
1110
1111       DefaultMethodId clas op _ ->
1112         case (getOrigName clas)         of { (c_mod, c_name) ->
1113         case (getClassOpString op)      of { op_name ->
1114         if fromPreludeCore clas
1115         then [SLIT("defm"), op_name]
1116         else [SLIT("defm"), c_mod, c_name, op_name] }}
1117
1118       DictFunId c ty _ _ ->
1119         case (getOrigName c)        of { (c_mod, c_name) ->
1120         let
1121             c_bits = if fromPreludeCore c
1122                      then [c_name]
1123                      else [c_mod, c_name]
1124
1125             ty_bits = getTypeString ty
1126         in
1127         [SLIT("dfun")] ++ c_bits ++ ty_bits }
1128
1129
1130       ConstMethodId c ty o _ _ ->
1131         case (getOrigName c)        of { (c_mod, c_name) ->
1132         case (getTypeString ty)     of { ty_bits ->
1133         case (getClassOpString o)   of { o_name ->
1134         case (if fromPreludeCore c
1135                 then []
1136                 else [c_mod, c_name])   of { c_bits ->
1137         [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1138
1139       -- if the unspecialised equiv is "top-level",
1140       -- the name must be concocted from its name and the
1141       -- names of the types to which specialised...
1142
1143       SpecId unspec ty_maybes _ ->
1144         getIdNamePieces show_uniqs unspec ++ (
1145         if not (toplevelishId unspec)
1146         then [showUnique u]
1147         else concat (map typeMaybeString ty_maybes)
1148         )
1149
1150       WorkerId unwrkr ->
1151         getIdNamePieces show_uniqs unwrkr ++ (
1152         if not (toplevelishId unwrkr)
1153         then [showUnique u]
1154         else [SLIT("wrk")]    -- show u
1155         )
1156
1157       InstId    inst     -> getInstNamePieces show_uniqs inst
1158       LocalId      n _   -> let local = getLocalName n in
1159                             if show_uniqs then [local, showUnique u] else [local]
1160       SysLocalId   n _   -> [getLocalName n, showUnique u]
1161       SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1162
1163 #ifdef DPH
1164       ProcessorCon a _ -> ["MkProcessor" ++ (show a)]
1165       PodId n ity id   -> getIdNamePieces show_uniqs id ++
1166                            ["mapped", "POD" ++ (show n), show ity]
1167 #endif {- Data Parallel Haskell -}
1168
1169 get_fullname_pieces :: FullName -> [FAST_STRING]
1170 get_fullname_pieces n
1171   = BIND (getOrigName n) _TO_ (mod, name) ->
1172     if fromPrelude mod
1173     then [name]
1174     else [mod, name]
1175     BEND
1176 \end{code}
1177
1178 Really Inst-ish, but only used in this module...
1179 \begin{code}
1180 getInstNamePieces :: Bool -> Inst -> [FAST_STRING]
1181
1182 getInstNamePieces show_uniqs (Dict   u clas ty _)
1183   = let  (mod, nm) = getOrigName clas  in
1184     if fromPreludeCore clas
1185     then [SLIT("d"), nm, showUnique u]
1186     else [SLIT("d"), mod, nm, showUnique u]
1187
1188 getInstNamePieces show_uniqs (Method u id tys  _)
1189   = let local = getIdNamePieces show_uniqs id in
1190     if show_uniqs then local ++ [showUnique u] else local
1191
1192 getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
1193 \end{code}
1194
1195 %************************************************************************
1196 %*                                                                      *
1197 \subsection[Id-type-funs]{Type-related @Id@ functions}
1198 %*                                                                      *
1199 %************************************************************************
1200
1201 \begin{code}
1202 getIdUniType :: Id -> UniType
1203
1204 getIdUniType (Id _ ty _ _) = ty
1205
1206 #ifdef DPH
1207 -- ToDo: DPH
1208 getIdUniType (ProcessorCon _ ty)        = ty
1209 getIdUniType (PodId d ity id)
1210   = let (foralls,rho) = splitForalls (getIdUniType id)          in
1211     let tys           = get_args rho                            in
1212     let itys_mask     = infoTypeNumToMask ity                   in
1213     let tys'          = zipWith convert tys itys_mask           in
1214     mkForallTy foralls (foldr1 mkFunTy tys')
1215   where -- ToDo(hilly) change to use getSourceType etc...
1216
1217     get_args ty = case (maybeUnpackFunTy ty) of
1218                     Nothing        -> [ty]
1219                     Just (arg,res) -> arg:get_args res
1220
1221     convert ty cond = if cond
1222                       then ty
1223                       else (coerce ty)
1224
1225     coerce ty = case (maybeUnpackFunTy ty) of
1226                   Nothing        ->mkPodizedPodNTy d ty
1227                   Just (arg,res) ->mkFunTy (coerce arg) (coerce res)
1228 #endif {- Data Parallel Haskell -}
1229 \end{code}
1230
1231 \begin{code}
1232 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1233
1234 getMentionedTyConsAndClassesFromId id
1235  = getMentionedTyConsAndClassesFromUniType (getIdUniType id)
1236 \end{code}
1237
1238 \begin{code}
1239 getIdKind i = kindFromType (getIdUniType i)
1240 \end{code}
1241
1242 \begin{code}
1243 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1244 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1245 getInstIdModule other = panic "Id:getInstIdModule"
1246 \end{code}
1247
1248
1249 \begin{code}
1250 {- NOT USED
1251 getIdTauType :: Id -> TauType
1252 getIdTauType i = expandTySyn (getTauType (getIdUniType i))
1253
1254 getIdSourceTypes :: Id -> [TauType]
1255 getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i)))
1256
1257 getIdTargetType :: Id -> TauType
1258 getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i)))
1259 -}
1260 \end{code}
1261
1262 %************************************************************************
1263 %*                                                                      *
1264 \subsection[Id-overloading]{Functions related to overloading}
1265 %*                                                                      *
1266 %************************************************************************
1267
1268 \begin{code}
1269 mkSuperDictSelId  u c sc     ty info = Id u ty info (SuperDictSelId c sc)
1270 mkClassOpId       u c op     ty info = Id u ty info (ClassOpId c op)
1271 mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen)
1272
1273 mkDictFunId u c ity full_ty from_here modname info
1274   = Id u full_ty info (DictFunId c ity from_here modname)
1275
1276 mkConstMethodId u c op ity full_ty from_here modname info
1277   = Id u full_ty info (ConstMethodId c ity op from_here modname)
1278
1279 mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr)
1280
1281 mkInstId inst
1282   = Id u (getInstUniType inst) noIdInfo (InstId inst)
1283   where
1284     u = case inst of
1285           Dict    u c t o   -> u
1286           Method  u i ts o  -> u
1287           LitInst u l ty o  -> u
1288
1289 {- UNUSED:
1290 getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class))
1291   = (input_class, result_class)
1292 -}
1293 \end{code}
1294
1295 %************************************************************************
1296 %*                                                                      *
1297 \subsection[local-funs]{@LocalId@-related functions}
1298 %*                                                                      *
1299 %************************************************************************
1300
1301 \begin{code}
1302 mkImported    u n ty info = Id u ty info (ImportedId   n)
1303 mkPreludeId   u n ty info = Id u ty info (PreludeId    n)
1304
1305 #ifdef DPH
1306 mkPodId d i = PodId d i
1307 #endif
1308
1309 updateIdType :: Id -> UniType -> Id
1310 updateIdType (Id u _ info details) ty = Id u ty info details
1311 \end{code}
1312
1313 \begin{code}
1314 no_free_tvs ty = null (extractTyVarsFromTy ty)
1315
1316 -- SysLocal: for an Id being created by the compiler out of thin air...
1317 -- UserLocal: an Id with a name the user might recognize...
1318 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> UniType -> SrcLoc -> Id
1319
1320 mkSysLocal str uniq ty loc
1321   = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty))
1322
1323 mkUserLocal str uniq ty loc
1324   = Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty))
1325
1326 -- for a SpecPragmaId being created by the compiler out of thin air...
1327 mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id
1328 mkSpecPragmaId str uniq ty specinfo loc
1329   = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty))
1330
1331 -- for new SpecId
1332 mkSpecId u unspec ty_maybes ty info
1333   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1334     Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1335
1336 -- Specialised version of constructor: only used in STG and code generation
1337 -- Note: The specialsied Id has the same unique as the unspeced Id
1338
1339 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1340   = ASSERT(isDataCon unspec)
1341     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1342     Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1343   where
1344     new_ty = specialiseTy ty ty_maybes 0
1345
1346     -- pprTrace "SameSpecCon:Unique:"
1347     --          (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
1348
1349 -- mkId builds a local or top-level Id, depending on the name given
1350 mkId :: Name -> UniType -> IdInfo -> Id
1351 mkId (Short uniq short) ty info = Id uniq ty info (LocalId short (no_free_tvs ty))
1352 mkId (OtherTopId uniq full) ty info
1353   = Id uniq ty info
1354         (if isLocallyDefined full then TopLevId full else ImportedId full)
1355
1356 localiseId :: Id -> Id
1357 localiseId id@(Id u ty info details)
1358   = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1359   where
1360     name = getOccurrenceName id
1361     loc  = getSrcLoc id
1362
1363 -- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
1364 -- ToDo: it does??? WDP
1365 mkIdWithNewUniq :: Id -> Unique -> Id
1366
1367 mkIdWithNewUniq (Id _ ty info details) uniq
1368   = let
1369         new_details
1370           = case details of
1371               InstId (Dict _ c t o)     -> InstId (Dict uniq c t o)
1372               InstId (Method _ i ts o)  -> InstId (Method uniq i ts o)
1373               InstId (LitInst _ l ty o) -> InstId (LitInst uniq l ty o)
1374               old_details               -> old_details
1375     in
1376     Id uniq ty info new_details
1377
1378 #ifdef DPH
1379 mkIdWithNewUniq (PodId d t id) uniq = PodId d t (mkIdWithNewUniq id uniq)
1380 #endif {- Data Parallel Haskell -}
1381 \end{code}
1382
1383 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
1384 @Uniques@, but that's OK because the templates are supposed to be
1385 instantiated before use.
1386 \begin{code}
1387 mkTemplateLocals :: [UniType] -> [Id]
1388 mkTemplateLocals tys
1389   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
1390             (getBuiltinUniques (length tys))
1391             tys
1392 \end{code}
1393
1394 \begin{code}
1395 getIdInfo :: Id -> IdInfo
1396
1397 getIdInfo (Id _ _ info _) = info
1398
1399 #ifdef DPH
1400 getIdInfo (PodId _ _ id)                = getIdInfo id
1401 #endif {- Data Parallel Haskell -}
1402
1403 replaceIdInfo :: Id -> IdInfo -> Id
1404
1405 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1406
1407 #ifdef DPH
1408 replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info)
1409 #endif {- Data Parallel Haskell -}
1410
1411 selectIdInfoForSpecId :: Id -> IdInfo
1412 selectIdInfoForSpecId unspec
1413   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1414     noIdInfo `addInfo_UF` getIdUnfolding unspec
1415 \end{code}
1416
1417 %************************************************************************
1418 %*                                                                      *
1419 \subsection[Id-arities]{Arity-related functions}
1420 %*                                                                      *
1421 %************************************************************************
1422
1423 For locally-defined Ids, the code generator maintains its own notion
1424 of their arities; so it should not be asking...  (but other things
1425 besides the code-generator need arity info!)
1426
1427 \begin{code}
1428 getIdArity      :: Id -> ArityInfo
1429 getDataConArity :: DataCon -> Int -- a simpler i/face; they always have arities
1430
1431 #ifdef DPH
1432 getIdArity (ProcessorCon n _)           = mkArityInfo n
1433 getIdArity (PodId _ _ id)               = getIdArity id
1434 #endif {- Data Parallel Haskell -}
1435
1436 getIdArity (Id _ _ id_info _)  = getInfo id_info
1437
1438 getDataConArity id@(Id _ _ id_info _)
1439   = ASSERT(isDataCon id)
1440     case (arityMaybe (getInfo id_info)) of
1441       Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
1442       Just  i -> i
1443
1444 addIdArity :: Id -> Int -> Id
1445 addIdArity (Id u ty info details) arity
1446   = Id u ty (info `addInfo` (mkArityInfo arity)) details
1447 \end{code}
1448
1449 %************************************************************************
1450 %*                                                                      *
1451 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1452 %*                                                                      *
1453 %************************************************************************
1454
1455 \begin{code}
1456 mkDataCon :: Unique{-DataConKey-} -> FullName -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
1457   -- can get the tag and all the pieces of the type from the UniType
1458
1459 mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con
1460   where
1461     data_con  = Id k type_of_constructor datacon_info
1462                     (DataConId n
1463                         (position_within fIRST_TAG data_con_family data_con)
1464                         tyvar_tmpls context args_tys tycon)
1465
1466     -- Note data_con self-recursion;
1467     -- should be OK as tags are not looked at until
1468     -- late in the game.
1469
1470     data_con_family             = getTyConDataCons tycon
1471
1472     position_within :: Int -> [Id] -> Id -> Int
1473     position_within acc [] con
1474       = panic "mkDataCon: con not found in family"
1475
1476     position_within acc (c:cs) con
1477       = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con
1478
1479     type_of_constructor = mkSigmaTy tyvar_tmpls context
1480                                 (glueTyArgs
1481                                         args_tys
1482                                         (applyTyCon tycon (map mkTyVarTemplateTy tyvar_tmpls)))
1483
1484     datacon_info = noIdInfo `addInfo_UF` unfolding
1485                             `addInfo` mkArityInfo arity
1486                             `addInfo` specenv
1487
1488     arity = length args_tys
1489
1490     unfolding
1491       = -- if arity == 0
1492         -- then noIdInfo
1493         -- else -- do some business...
1494         let
1495             (tyvars, dict_vars, vars) = mk_uf_bits tyvar_tmpls context args_tys tycon
1496             tyvar_tys = map mkTyVarTy tyvars
1497         in
1498         BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
1499
1500         BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
1501
1502         mkUnfolding EssentialUnfolding -- for data constructors
1503                     (foldr CoTyLam lambdized_CoCon tyvars)
1504         BEND BEND
1505
1506     mk_uf_bits tyvar_tmpls context arg_tys tycon
1507       = let
1508             (inst_env, tyvars, tyvar_tys)
1509               = instantiateTyVarTemplates tyvar_tmpls
1510                                           (map getTheUnique tyvar_tmpls)
1511         in
1512             -- the "context" and "arg_tys" have TyVarTemplates in them, so
1513             -- we instantiate those types to have the right TyVars in them
1514             -- instead.
1515         BIND (map (instantiateTauTy inst_env) (map ctxt_ty context))
1516                                                         _TO_ inst_dict_tys ->
1517         BIND (map (instantiateTauTy inst_env) arg_tys)  _TO_ inst_arg_tys ->
1518
1519             -- We can only have **ONE** call to mkTemplateLocals here;
1520             -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1521             -- (Mega-Sigh) [ToDo]
1522         BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1523
1524         BIND (splitAt (length context) all_vars)        _TO_ (dict_vars, vars) ->
1525
1526         (tyvars, dict_vars, vars)
1527         BEND BEND BEND BEND
1528       where
1529         -- these are really dubious UniTypes, but they are only to make the
1530         -- binders for the lambdas for tossed-away dicts.
1531         ctxt_ty (clas, ty) = mkDictTy clas ty
1532 \end{code}
1533
1534 \begin{code}
1535 mkTupleCon :: Arity -> Id
1536
1537 mkTupleCon arity = data_con
1538   where
1539     data_con    = Id unique ty tuplecon_info (TupleConId arity)
1540     unique      = mkTupleDataConUnique arity
1541     ty          = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
1542     tycon       = mkTupleTyCon arity
1543     tyvars      = take arity alphaTyVars
1544     tyvar_tys   = map mkTyVarTemplateTy tyvars
1545
1546     tuplecon_info
1547       = noIdInfo `addInfo_UF` unfolding
1548                  `addInfo` mkArityInfo arity
1549                  `addInfo` pcGenerateTupleSpecs arity ty
1550
1551     unfolding
1552       = -- if arity == 0
1553         -- then noIdInfo
1554         -- else -- do some business...
1555         let
1556             (tyvars, dict_vars, vars) = mk_uf_bits arity
1557             tyvar_tys = map mkTyVarTy tyvars
1558         in
1559         BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
1560
1561         BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
1562
1563         mkUnfolding
1564             EssentialUnfolding    -- data constructors
1565             (foldr CoTyLam lambdized_CoCon tyvars)
1566         BEND BEND
1567
1568     mk_uf_bits arity
1569       = BIND (mkTemplateLocals tyvar_tys)                _TO_ vars ->
1570         (tyvars, [], vars)
1571         BEND
1572       where
1573         tyvar_tmpls     = take arity alphaTyVars
1574         (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
1575
1576
1577 #ifdef DPH
1578 mkProcessorCon :: Arity -> Id
1579 mkProcessorCon arity
1580   = ProcessorCon arity ty
1581   where
1582     ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
1583     tycon       = mkProcessorTyCon arity
1584     tyvars      = take arity alphaTyVars
1585     tyvar_tys   = map mkTyVarTemplateTy tyvars
1586 #endif {- Data Parallel Haskell -}
1587
1588 fIRST_TAG :: ConTag
1589 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1590
1591 -- given one data constructor in a family, return a list
1592 -- of all the data constructors in that family.
1593
1594 #ifdef DPH
1595 getDataConFamily :: DataCon -> [DataCon]
1596
1597 getDataConFamily data_con
1598   = ASSERT(isDataCon data_con)
1599     getTyConDataCons (getDataConTyCon data_con)
1600 #endif
1601 \end{code}
1602
1603 \begin{code}
1604 getDataConTag :: DataCon -> ConTag      -- will panic if not a DataCon
1605
1606 getDataConTag   (Id _ _ _ (DataConId _ tag _ _ _ _)) = tag
1607 getDataConTag   (Id _ _ _ (TupleConId _))            = fIRST_TAG
1608 getDataConTag   (Id _ _ _ (SpecId unspec _ _))       = getDataConTag unspec
1609 #ifdef DPH
1610 getDataConTag   (ProcessorCon _ _) = fIRST_TAG
1611 #endif {- Data Parallel Haskell -}
1612
1613 getDataConTyCon :: DataCon -> TyCon     -- will panic if not a DataCon
1614
1615 getDataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ tycon)) = tycon
1616 getDataConTyCon (Id _ _ _ (TupleConId a))              = mkTupleTyCon a
1617 getDataConTyCon (Id _ _ _ (SpecId unspec tys _))       = mkSpecTyCon (getDataConTyCon unspec) tys
1618 #ifdef DPH
1619 getDataConTyCon (ProcessorCon a _) = mkProcessorTyCon a
1620 #endif {- Data Parallel Haskell -}
1621
1622 getDataConSig :: DataCon -> ([TyVarTemplate], ThetaType, [TauType], TyCon)
1623                                         -- will panic if not a DataCon
1624
1625 getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon))
1626   = (tyvars, theta_ty, arg_tys, tycon)
1627
1628 getDataConSig (Id _ _ _ (TupleConId arity))
1629   = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1630   where
1631     tyvars      = take arity alphaTyVars
1632     tyvar_tys   = map mkTyVarTemplateTy tyvars
1633
1634 getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
1635   = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
1636   where
1637     (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
1638
1639     ty_env = tyvars `zip` ty_maybes
1640
1641     spec_tyvars = foldr nothing_tyvars [] ty_env
1642     nothing_tyvars (tyvar, Nothing) l = tyvar : l
1643     nothing_tyvars (tyvar, Just ty) l = l
1644
1645     spec_env = foldr just_env [] ty_env
1646     just_env (tyvar, Nothing) l = l
1647     just_env (tyvar, Just ty) l = (tyvar, ty) : l
1648     spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
1649
1650     spec_theta_ty = if null theta_ty then []
1651                     else panic "getDataConSig:ThetaTy:SpecDataCon"
1652     spec_tycon    = mkSpecTyCon tycon ty_maybes
1653
1654 #ifdef DPH
1655 getDataConSig (ProcessorCon arity _)
1656   = (tyvars, [], tyvar_tys, mkProcessorTyCon arity)
1657   where
1658     tyvars      = take arity alphaTyVars
1659     tyvar_tys   = map mkTyVarTemplateTy tyvars
1660 #endif {- Data Parallel Haskell -}
1661 \end{code}
1662
1663 @getInstantiatedDataConSig@ takes a constructor and some types to which
1664 it is applied; it returns its signature instantiated to these types.
1665
1666 \begin{code}
1667 getInstantiatedDataConSig ::
1668            DataCon      -- The data constructor
1669                         --   Not a specialised data constructor
1670         -> [TauType]    -- Types to which applied
1671                         --   Must be fully applied i.e. contain all types of tycon
1672         -> ([TauType],  -- Types of dict args
1673             [TauType],  -- Types of regular args
1674             TauType     -- Type of result
1675            )
1676
1677 getInstantiatedDataConSig data_con tycon_arg_tys
1678   = ASSERT(isDataCon data_con)
1679     --false?? WDP 95/06: ASSERT(not (maybeToBool (isSpecId_maybe data_con)))
1680     let
1681         (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) = getDataConSig data_con
1682
1683         inst_env = --ASSERT(length tv_tmpls == length tycon_arg_tys)
1684 {-                 if (length tv_tmpls /= length tycon_arg_tys) then
1685                         pprPanic "Id:1666:" (ppCat [ppr PprShowAll data_con, ppr PprDebug tycon_arg_tys])
1686                    else
1687 -}                 tv_tmpls `zip` tycon_arg_tys
1688
1689         theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1690         cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
1691         result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
1692     in
1693     -- Are the first/third results ever used?
1694     (theta_tys, cmpnt_tys, result_ty)
1695
1696 {- UNUSED: allows a specilaised constructor to be instantiated
1697            (with all argument types of the unspecialsied tycon)
1698
1699 getInstantiatedDataConSig data_con tycon_arg_tys
1700   = ASSERT(isDataCon data_con)
1701     if is_speccon && arg_tys_match_error then
1702         pprPanic "getInstantiatedDataConSig:SpecId:"
1703                  (ppHang (ppr PprDebug data_con) 4 pp_match_error)
1704     else
1705         (theta_tys, cmpnt_tys, result_ty)  -- Are the first/third results ever used?
1706   where
1707     is_speccon       = maybeToBool is_speccon_maybe
1708     is_speccon_maybe = isSpecId_maybe data_con
1709     Just (unspec_con, spec_tys) = is_speccon_maybe
1710
1711     arg_tys_match_error = maybeToBool match_error_maybe
1712     match_error_maybe   = ASSERT(length spec_tys == length tycon_arg_tys)
1713                           argTysMatchSpecTys spec_tys tycon_arg_tys
1714     (Just pp_match_error) = match_error_maybe
1715
1716     (tv_tmpls, theta, cmpnt_ty_tmpls, tycon)
1717       = if is_speccon
1718         then getDataConSig unspec_con
1719         else getDataConSig data_con
1720
1721     inst_env = ASSERT(length tv_tmpls == length tycon_arg_tys)
1722                tv_tmpls `zip` tycon_arg_tys
1723
1724     theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1725     cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
1726     result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
1727 -}
1728 \end{code}
1729
1730 The function @getDataConDeps@ is passed an @Id@ representing a data
1731 constructor of some type. We look at the source types of the
1732 constructor and create the set of all @TyCons@ referred to directly
1733 from the source types.
1734
1735 \begin{code}
1736 #ifdef USE_SEMANTIQUE_STRANAL
1737 getDataConDeps :: Id -> [TyCon]
1738
1739 getDataConDeps (Id _ _ _ (DataConId _ _ _ _ arg_tys _))
1740   = concat (map getReferredToTyCons arg_tys)
1741 getDataConDeps (Id _ _ _ (TupleConId _)) = []
1742 getDataConDeps (Id _ _ _ (SpecId unspec ty_maybes _))
1743   = getDataConDeps unspec ++ concat (map getReferredToTyCons (catMaybes ty_maybes))
1744 #ifdef DPH
1745 getDataConDeps (ProcessorCon _ _) = []
1746 #endif {- Data Parallel Haskell -}
1747 #endif {- Semantique strictness analyser -}
1748 \end{code}
1749
1750 Data type declarations are of the form:
1751 \begin{verbatim}
1752 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1753 \end{verbatim}
1754 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1755 @C1 x y z@, we want a function binding:
1756 \begin{verbatim}
1757 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> CoCon C1 [a, b] [x, y, z]
1758 \end{verbatim}
1759 Notice the ``big lambdas'' and type arguments to @CoCon@---we are producing
1760 2nd-order polymorphic lambda calculus with explicit types.
1761
1762 %************************************************************************
1763 %*                                                                      *
1764 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1765 %*                                                                      *
1766 %************************************************************************
1767
1768 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1769 and generates an @UnfoldingDetails@ for its unfolding.  The @Ids@ and
1770 @TyVars@ don't really have to be new, because we are only producing a
1771 template.
1772
1773 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1774 --WDP)?
1775
1776 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1777 EXPORTED.  It just returns the binders (@TyVars@ and @Ids@) [in the
1778 example above: a, b, and x, y, z], which is enough (in the important
1779 \tr{DsExpr} case).  (The middle set of @Ids@ is binders for any
1780 dictionaries, in the even of an overloaded data-constructor---none at
1781 present.)
1782
1783 \begin{code}
1784 getIdUnfolding      :: Id -> UnfoldingDetails
1785
1786 #ifdef DPH
1787 getIdUnfolding dcon@(ProcessorCon arity _)
1788   = let
1789         (tyvars, dict_vars, vars) = getDataConUnfolding dcon
1790         tyvar_tys = map mkTyVarTy tyvars
1791     in
1792     BIND (CoCon dcon tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
1793     BIND (mkCoLam vars plain_CoCon)              _TO_ lambdized_CoCon ->
1794     mkUnfoldTemplate (\x->False){-ToDo-} EssentialUnfolding{-ToDo???DPH-} (foldr CoTyLam lambdized_CoCon tyvars)
1795     BEND BEND
1796
1797 -- If we have a PodId whose ``id'' has an unfolding, then we need to
1798 -- parallelize the unfolded expression for the d^th dimension.
1799 {-
1800 getIdUnfolding (PodId d _ id)
1801    = case (unfoldingMaybe (getIdUnfolding id)) of
1802         Nothing   -> noInfo
1803         Just expr -> trace ("getIdUnfolding ("++
1804                             ppShow 80 (ppr PprDebug id) ++
1805                             ") for " ++ show d ++ "D pod")
1806                            (podizeTemplateExpr d expr)
1807 -}
1808 #endif {- Data Parallel Haskell -}
1809
1810 getIdUnfolding (Id _ _ id_info _) = getInfo_UF id_info
1811
1812 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1813 addIdUnfolding id@(Id u ty info details) unfold_details
1814   = ASSERT(
1815         case (isLocallyDefined id, unfold_details) of
1816         (_,     NoUnfoldingDetails) -> True
1817         (True,  IWantToBeINLINEd _) -> True
1818         (False, IWantToBeINLINEd _) -> False -- v bad
1819         (False, _)                  -> True
1820         _                           -> False -- v bad
1821     )
1822     Id u ty (info `addInfo_UF` unfold_details) details
1823
1824 {- UNUSED:
1825 clearIdUnfolding :: Id -> Id
1826 clearIdUnfolding (Id u ty info details) = Id u ty (clearInfo_UF info) details
1827 -}
1828 \end{code}
1829
1830 In generating selector functions (take a dictionary, give back one
1831 component...), we need to what out for the nothing-to-select cases (in
1832 which case the ``selector'' is just an identity function):
1833 \begin{verbatim}
1834 class Eq a => Foo a { }     # the superdict selector for "Eq"
1835
1836 class Foo a { op :: Complex b => c -> b -> a }
1837                             # the method selector for "op";
1838                             # note local polymorphism...
1839 \end{verbatim}
1840
1841 For data constructors, we make an unfolding which has a bunch of
1842 lambdas to bind the arguments, with a (saturated) @CoCon@ inside.  In
1843 the case of overloaded constructors, the dictionaries are just thrown
1844 away; they were only required in the first place to ensure that the
1845 type was indeed an instance of the required class.
1846 \begin{code}
1847 #ifdef DPH
1848 getDataConUnfolding :: Id -> ([TyVar], [Id], [Id])
1849
1850 getDataConUnfolding dcon@(ProcessorCon arity _)
1851   = BIND (mkTemplateLocals tyvar_tys)            _TO_ vars ->
1852     (tyvars, [], vars)
1853     BEND
1854   where
1855     tyvar_tmpls = take arity alphaTyVars
1856     (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
1857 #endif {- Data Parallel Haskell -}
1858 \end{code}
1859
1860 %************************************************************************
1861 %*                                                                      *
1862 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1863 %*                                                                      *
1864 %************************************************************************
1865
1866 \begin{code}
1867 getIdDemandInfo :: Id -> DemandInfo
1868 getIdDemandInfo (Id _ _ info _) = getInfo info
1869
1870 addIdDemandInfo :: Id -> DemandInfo -> Id
1871 addIdDemandInfo (Id u ty info details) demand_info
1872   = Id u ty (info `addInfo` demand_info) details
1873 \end{code}
1874
1875 \begin{code}
1876 getIdUpdateInfo :: Id -> UpdateInfo
1877 getIdUpdateInfo (Id u ty info details) = getInfo info
1878
1879 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1880 addIdUpdateInfo (Id u ty info details) upd_info
1881   = Id u ty (info `addInfo` upd_info) details
1882 \end{code}
1883
1884 \begin{code}
1885 getIdArgUsageInfo :: Id -> ArgUsageInfo
1886 getIdArgUsageInfo (Id u ty info details) = getInfo info
1887
1888 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1889 addIdArgUsageInfo (Id u ty info details) au_info
1890   = Id u ty (info `addInfo` au_info) details
1891 \end{code}
1892
1893 \begin{code}
1894 getIdFBTypeInfo :: Id -> FBTypeInfo
1895 getIdFBTypeInfo (Id u ty info details) = getInfo info
1896
1897 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1898 addIdFBTypeInfo (Id u ty info details) upd_info
1899   = Id u ty (info `addInfo` upd_info) details
1900 \end{code}
1901
1902 \begin{code}
1903 getIdSpecialisation :: Id -> SpecEnv
1904 getIdSpecialisation (Id _ _ info _) = getInfo info
1905
1906 addIdSpecialisation :: Id -> SpecEnv -> Id
1907 addIdSpecialisation (Id u ty info details) spec_info
1908   = Id u ty (info `addInfo` spec_info) details
1909 \end{code}
1910
1911 Strictness: we snaffle the info out of the IdInfo.
1912
1913 \begin{code}
1914 getIdStrictness :: Id -> StrictnessInfo
1915
1916 getIdStrictness (Id _ _ id_info _) = getInfo id_info
1917
1918 addIdStrictness :: Id -> StrictnessInfo -> Id
1919
1920 addIdStrictness (Id u ty info details) strict_info
1921   = Id u ty (info `addInfo` strict_info) details
1922 \end{code}
1923
1924 %************************************************************************
1925 %*                                                                      *
1926 \subsection[Id-comparison]{Comparison functions for @Id@s}
1927 %*                                                                      *
1928 %************************************************************************
1929
1930 Comparison: equality and ordering---this stuff gets {\em hammered}.
1931
1932 \begin{code}
1933 cmpId (Id u1 _ _ _) (Id u2 _ _ _) = cmpUnique u1 u2
1934 -- short and very sweet
1935 \end{code}
1936
1937 \begin{code}
1938 eqId :: Id -> Id -> Bool
1939
1940 eqId a b = case cmpId a b of { EQ_ -> True;  _   -> False }
1941
1942 instance Eq Id where
1943     a == b = case cmpId a b of { EQ_ -> True;  _ -> False }
1944     a /= b = case cmpId a b of { EQ_ -> False; _ -> True  }
1945
1946 instance Ord Id where
1947     a <= b = case cmpId a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1948     a <  b = case cmpId a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1949     a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1950     a >  b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1951 #ifdef __GLASGOW_HASKELL__
1952     _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1953 #endif
1954 \end{code}
1955
1956 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1957 account when comparing two data constructors. We need to do this
1958 because a specialsied data constructor has the same unique as its
1959 unspeciailsed counterpart.
1960
1961 \begin{code}
1962 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1963
1964 cmpId_withSpecDataCon id1 id2
1965   | eq_ids && isDataCon id1 && isDataCon id2
1966   = cmpEqDataCon id1 id2
1967
1968   | otherwise
1969   = cmp_ids
1970   where
1971     cmp_ids = cmpId id1 id2
1972     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1973
1974 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
1975   = cmpUniTypeMaybeList mtys1 mtys2
1976
1977 cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
1978   = LT_
1979
1980 cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
1981   = GT_
1982
1983 cmpEqDataCon unspec1 unspec2
1984   = EQ_
1985
1986 \end{code}
1987
1988 %************************************************************************
1989 %*                                                                      *
1990 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1991 %*                                                                      *
1992 %************************************************************************
1993
1994 \begin{code}
1995 instance Outputable Id where
1996     ppr sty id = pprId sty id
1997
1998 showId :: PprStyle -> Id -> String
1999 showId sty id = ppShow 80 (pprId sty id)
2000
2001 -- [used below]
2002 -- for DictFuns (instances) and const methods (instance code bits we
2003 -- can call directly): exported (a) if *either* the class or
2004 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
2005 -- class and tycon are from PreludeCore [non-std, but convenient]
2006 -- *and* the thing was defined in this module.
2007
2008 instance_export_flag :: Class -> UniType -> Bool -> ExportFlag
2009
2010 instance_export_flag clas inst_ty from_here
2011   = if instanceIsExported clas inst_ty from_here
2012     then ExportAll
2013     else NotExported
2014 \end{code}
2015
2016 Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
2017 PreludeCore''?  True if the outermost TyCon is fromPreludeCore.
2018 \begin{code}
2019 is_prelude_core_ty :: UniType -> Bool
2020
2021 is_prelude_core_ty inst_ty
2022   = case getUniDataTyCon_maybe inst_ty of
2023       Just (tycon,_,_) -> fromPreludeCore tycon
2024       Nothing          -> panic "Id: is_prelude_core_ty"
2025 \end{code}
2026
2027 Default printing code (not used for interfaces):
2028 \begin{code}
2029 pprId :: PprStyle -> Id -> Pretty
2030
2031 pprId other_sty id
2032   = let
2033         pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
2034
2035         for_code
2036           = let
2037                 pieces_to_print -- maybe use Unique only
2038                   = if isSysLocalId id then tail pieces else pieces
2039             in
2040             ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
2041     in
2042     case other_sty of
2043       PprForC _       -> for_code
2044       PprForAsm _ _ _ -> for_code
2045       PprInterface _  -> ppPStr occur_name
2046       PprForUser      -> ppPStr occur_name
2047       PprUnfolding _  -> qualified_name pieces
2048       PprDebug        -> qualified_name pieces
2049       PprShowAll      -> ppBesides [qualified_name pieces,
2050                             (ppCat [pp_uniq id,
2051                                     ppPStr SLIT("{-"),
2052                                     ppr other_sty (getIdUniType id),
2053                                     ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id),
2054                                     ppPStr SLIT("-}") ])]
2055   where
2056     occur_name = getOccurrenceName id _APPEND_
2057                  ( _PK_ (if not (isSysLocalId id)
2058                          then ""
2059                          else "." ++ (_UNPK_ (showUnique (getTheUnique id)))))
2060
2061     qualified_name pieces
2062       = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
2063
2064     pp_uniq (Id _ _ _ (PreludeId _))    = ppNil -- No uniq to add
2065     pp_uniq (Id _ _ _ (DataConId _ _ _ _ _ _)) = ppNil  -- No uniq to add
2066     pp_uniq (Id _ _ _ (TupleConId _))       = ppNil -- No uniq to add
2067     pp_uniq (Id _ _ _ (LocalId      _ _))   = ppNil -- uniq printed elsewhere
2068     pp_uniq (Id _ _ _ (SysLocalId   _ _))   = ppNil -- ditto
2069     pp_uniq (Id _ _ _ (SpecPragmaId _ _ _)) = ppNil -- ditto
2070     pp_uniq (Id _ _ _ (InstId _))           = ppNil -- ditto
2071     pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getTheUnique other_id),  ppPStr SLIT("-}")]
2072
2073     -- For Robin Popplestone: print PprDebug Ids with # afterwards
2074     -- if they are of primitive type.
2075     pp_ubxd pretty = if isPrimType (getIdUniType id)
2076                      then ppBeside pretty (ppChar '#')
2077                      else pretty
2078 \end{code}
2079
2080 \begin{code}
2081 instance NamedThing Id where
2082     getExportFlag (Id _ _ _ details)
2083       = get details
2084       where
2085         get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
2086         get (TupleConId _)          = NotExported
2087         get (ImportedId  n)         = getExportFlag n
2088         get (PreludeId   n)         = getExportFlag n
2089         get (TopLevId    n)         = getExportFlag n
2090         get (SuperDictSelId c _)    = getExportFlag c
2091         get (ClassOpId  c _)        = getExportFlag c
2092         get (DefaultMethodId c _ _) = getExportFlag c
2093         get (DictFunId  c ty from_here _) = instance_export_flag c ty from_here
2094         get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
2095         get (SpecId unspec _ _)     = getExportFlag unspec
2096         get (WorkerId unwrkr)       = getExportFlag unwrkr
2097         get (InstId _)              = NotExported
2098         get (LocalId      _ _)      = NotExported
2099         get (SysLocalId   _ _)      = NotExported
2100         get (SpecPragmaId _ _ _)    = NotExported
2101 #ifdef DPH
2102         get (ProcessorCon _ _)      = NotExported
2103         get (PodId _ _ i)           = getExportFlag i
2104 #endif {- Data Parallel Haskell -}
2105
2106     isLocallyDefined this_id@(Id _ _ _ details)
2107       = get details
2108       where
2109         get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
2110         get (TupleConId _)          = False
2111         get (ImportedId _)          = False
2112         get (PreludeId  _)          = False
2113         get (TopLevId   n)          = isLocallyDefined n
2114         get (SuperDictSelId c _)    = isLocallyDefined c
2115         get (ClassOpId c _)         = isLocallyDefined c
2116         get (DefaultMethodId c _ _) = isLocallyDefined c
2117         get (DictFunId c tyc from_here _) = from_here
2118             -- For DictFunId and ConstMethodId things, you really have to
2119             -- know whether it came from an imported instance or one
2120             -- really here; no matter where the tycon and class came from.
2121
2122         get (ConstMethodId c tyc _ from_here _) = from_here
2123         get (SpecId unspec _ _)     = isLocallyDefined unspec
2124         get (WorkerId unwrkr)       = isLocallyDefined unwrkr
2125         get (InstId  _)             = True
2126         get (LocalId      _ _)      = True
2127         get (SysLocalId   _ _)      = True
2128         get (SpecPragmaId _ _ _)    = True
2129 #ifdef DPH
2130         get (ProcessorCon _ _)      = False
2131         get (PodId _ _ i)           = isLocallyDefined i
2132 #endif {- Data Parallel Haskell -}
2133
2134     getOrigName this_id@(Id u _ _ details)
2135       = get details
2136       where
2137         get (DataConId n _ _ _ _ _) = getOrigName n
2138         get (TupleConId a)          = (pRELUDE_BUILTIN, SLIT("Tup") _APPEND_ _PK_ (show a))
2139         get (ImportedId   n)        = getOrigName n
2140         get (PreludeId    n)        = getOrigName n
2141         get (TopLevId     n)        = getOrigName n
2142
2143         get (ClassOpId c op)        = case (getOrigName c) of -- ToDo; better ???
2144                                         (mod, _) -> (mod, getClassOpString op)
2145
2146         get (SpecId unspec ty_maybes _)
2147           = BIND getOrigName unspec           _TO_ (mod, unspec_nm) ->
2148             BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
2149             (mod,
2150              unspec_nm _APPEND_
2151                 (if not (toplevelishId unspec)
2152                  then showUnique u
2153                  else tys_suffix)
2154             )
2155             BEND BEND
2156
2157         get (WorkerId unwrkr)
2158           = BIND getOrigName unwrkr     _TO_ (mod, unwrkr_nm) ->
2159             (mod,
2160              unwrkr_nm _APPEND_
2161                 (if not (toplevelishId unwrkr)
2162                  then showUnique u
2163                  else SLIT(".wrk"))
2164             )
2165             BEND
2166
2167         get (InstId inst)
2168           = (panic "NamedThing.Id.getOrigName (InstId)",
2169              BIND (getInstNamePieces True inst)   _TO_ (piece1:pieces) ->
2170              BIND [ _CONS_ '.' p | p <- pieces ]  _TO_ dotted_pieces ->
2171              _CONCAT_ (piece1 : dotted_pieces)
2172              BEND BEND )
2173
2174         get (LocalId      n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
2175                                   getLocalName n)
2176         get (SysLocalId   n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
2177                                   getLocalName n)
2178         get (SpecPragmaId n _ _)=(panic "NamedThing.Id.getOrigName (SpecPragmaId)",
2179                                   getLocalName n)
2180 #ifdef DPH
2181         get (ProcessorCon a _)      = ("PreludeBuiltin",
2182                                                    "MkProcessor" ++ (show a))
2183         get (PodId d ity id)
2184           = BIND (getOrigName id) _TO_ (m,n) ->
2185             (m,n ++ ".mapped.POD"++ show d ++ "." ++ show ity)
2186             BEND
2187     -- ToDo(hilly): should the above be using getIdNamePieces???
2188 #endif {- Data Parallel Haskell -}
2189
2190         get other_details
2191             -- the remaining internally-generated flavours of
2192             -- Ids really do not have meaningful "original name" stuff,
2193             -- but we need to make up something (usually for debugging output)
2194
2195           = BIND (getIdNamePieces True this_id)  _TO_ (piece1:pieces) ->
2196             BIND [ _CONS_ '.' p | p <- pieces ]  _TO_ dotted_pieces ->
2197             (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
2198             BEND BEND
2199
2200     getOccurrenceName this_id@(Id _ _ _ details)
2201       = get details
2202       where
2203         get (DataConId  n _ _ _ _ _) = getOccurrenceName n
2204         get (TupleConId a)      = SLIT("Tup") _APPEND_ (_PK_ (show a))
2205         get (ImportedId  n)     = getOccurrenceName n
2206         get (PreludeId   n)     = getOccurrenceName n
2207         get (TopLevId    n)     = getOccurrenceName n
2208         get (ClassOpId _ op)    = getClassOpString op
2209 #ifdef DPH
2210         get (ProcessorCon a _)  = "MkProcessor" ++ (show a)
2211         get (PodId _ _ id)      = getOccurrenceName id
2212 #endif {- Data Parallel Haskell -}
2213         get _                   = snd (getOrigName this_id)
2214
2215     getInformingModules id = panic "getInformingModule:Id"
2216
2217     getSrcLoc (Id _ _ id_info details)
2218       = get details
2219       where
2220         get (DataConId  n _ _ _ _ _) = getSrcLoc n
2221         get (TupleConId _)      = mkBuiltinSrcLoc
2222         get (ImportedId  n)     = getSrcLoc n
2223         get (PreludeId   n)     = getSrcLoc n
2224         get (TopLevId    n)     = getSrcLoc n
2225         get (SuperDictSelId c _)= getSrcLoc c
2226         get (ClassOpId c _)     = getSrcLoc c
2227         get (SpecId unspec _ _) = getSrcLoc unspec
2228         get (WorkerId unwrkr)   = getSrcLoc unwrkr
2229         get (InstId     i)      = let (loc,_) = getInstOrigin i
2230                                   in  loc
2231         get (LocalId      n _)  = getSrcLoc n
2232         get (SysLocalId   n _)  = getSrcLoc n
2233         get (SpecPragmaId n _ _)= getSrcLoc n
2234 #ifdef DPH
2235         get (ProcessorCon _ _)  = mkBuiltinSrcLoc
2236         get (PodId _ _ n)               = getSrcLoc n
2237 #endif {- Data Parallel Haskell -}
2238         -- well, try the IdInfo
2239         get something_else = getSrcLocIdInfo id_info
2240
2241     getTheUnique (Id u _ _ _) = u
2242
2243     fromPreludeCore (Id _ _ _ details)
2244       = get details
2245       where
2246         get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
2247         get (TupleConId _)          = True
2248         get (ImportedId  n)         = fromPreludeCore n
2249         get (PreludeId   n)         = fromPreludeCore n
2250         get (TopLevId    n)         = fromPreludeCore n
2251         get (SuperDictSelId c _)    = fromPreludeCore c
2252         get (ClassOpId c _)         = fromPreludeCore c
2253         get (DefaultMethodId c _ _) = fromPreludeCore c
2254         get (DictFunId  c t _ _)    = fromPreludeCore c && is_prelude_core_ty t
2255         get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
2256         get (SpecId unspec _ _)     = fromPreludeCore unspec
2257         get (WorkerId unwrkr)       = fromPreludeCore unwrkr
2258         get (InstId   _)            = False
2259         get (LocalId      _ _)      = False
2260         get (SysLocalId   _ _)      = False
2261         get (SpecPragmaId _ _ _)    = False
2262 #ifdef DPH
2263         get (ProcessorCon _ _)      = True
2264         get (PodId _ _ id)          = fromPreludeCore id
2265 #endif {- Data Parallel Haskell -}
2266
2267     hasType id  = True
2268     getType id  = getIdUniType id
2269 \end{code}
2270
2271 Reason for @getTheUnique@: The code generator doesn't carry a
2272 @UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
2273 given to it.