Id.lhs 64.3 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 4 5 6 7 8
%
\section[Id]{@Ids@: Value and constructor identifiers}

\begin{code}
#include "HsVersions.h"

9 10 11
module Id {- (
	GenId, Id(..),		-- Abstract
	StrictnessMark(..),	-- An enumaration
12 13 14 15 16 17
	ConTag(..), DictVar(..), DictFun(..), DataCon(..),

	-- CONSTRUCTION
	mkSysLocal, mkUserLocal,
	mkSpecPragmaId,
	mkSpecId, mkSameSpecCon,
18
	selectIdInfoForSpecId,
19 20 21 22
	mkTemplateLocals,
	mkImported, mkPreludeId,
	mkDataCon, mkTupleCon,
	mkIdWithNewUniq,
23 24
	mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
	mkConstMethodId, getConstMethodId,
25 26

	updateIdType,
27
	mkId, mkDictFunId, mkInstId,
28 29 30 31
	mkWorkerId,
	localiseId,

	-- DESTRUCTION
32 33 34 35
	idType,
	getIdInfo, replaceIdInfo,
	getPragmaInfo,
	getIdPrimRep, getInstIdModule,
36 37 38
	getMentionedTyConsAndClassesFromId,
	getDataConTag,
	getDataConSig, getInstantiatedDataConSig,
39 40

	getDataConTyCon,
41 42

	-- PREDICATES
43
	isDataCon, isTupleCon,
44 45 46 47 48
	isSpecId_maybe, isSpecPragmaId_maybe,
	toplevelishId, externallyVisibleId,
	isTopLevId, isWorkerId, isWrapperId,
	isImportedId, isSysLocalId,
	isBottomingId,
49 50 51 52
	isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
	isDictFunId,
--???	isInstId_maybe,
	isConstMethodId_maybe,
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
	cmpId_withSpecDataCon,
	myWrapperMaybe,
	whatsMentionedInId,
	unfoldingUnfriendlyId,	-- ToDo: rm, eventually
	idWantsToBeINLINEd,
--	dataConMentionsNonPreludeTyCon,

	-- SUBSTITUTION
	applySubstToId, applyTypeEnvToId,
-- not exported:	apply_to_Id, -- please don't use this, generally

	-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
	getIdArity, getDataConArity, addIdArity,
	getIdDemandInfo, addIdDemandInfo,
	getIdSpecialisation, addIdSpecialisation,
	getIdStrictness, addIdStrictness,
69
	getIdUnfolding, addIdUnfolding,
70 71 72 73 74 75 76 77 78 79 80
	getIdUpdateInfo, addIdUpdateInfo,
	getIdArgUsageInfo, addIdArgUsageInfo,
	getIdFBTypeInfo, addIdFBTypeInfo,
	-- don't export the types, lest OptIdInfo be dragged in!

	-- MISCELLANEOUS
	unlocaliseId,
	fIRST_TAG,
	showId,
	pprIdInUnfolding,

81 82 83 84 85 86
	-- "Environments" keyed off of Ids, and sets of Ids
	IdEnv(..),
	lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
	growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
	delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
	rngIdEnv, mapIdEnv,
87

88 89 90
	-- and to make the interface self-sufficient...
	GenIdSet(..), IdSet(..)
    )-} where
91

92 93 94 95
import Ubiq
import IdLoop   -- for paranoia checking
import TyLoop   -- for paranoia checking
import NameLoop -- for paranoia checking
96 97

import Bag
98 99 100 101
import Class		( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import IdInfo
import Maybes		( maybeToBool )
import NameTypes	( mkShortName, fromPrelude, FullName, ShortName )
102
import Name		( Name(..) )
103 104 105 106 107 108 109 110 111 112
import Outputable	( isAvarop, isAconop, getLocalName,
			  isExported, ExportFlag(..) )
import PragmaInfo	( PragmaInfo(..) )
import PrelMods		( pRELUDE_BUILTIN )
import PprType		( GenType, GenTyVar,
			  getTypeString, typeMaybeString, specMaybeTysSuffix )
import PprStyle
import Pretty
import SrcLoc		( mkBuiltinSrcLoc )
import TyCon		( TyCon, mkTupleTyCon, getTyConDataCons )
113 114 115 116 117 118
import Type		( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
			  applyTyCon, isPrimType, instantiateTy,
			  tyVarsOfType,
			  GenType, ThetaType(..), TauType(..), Type(..)
			)
import TyVar		( GenTyVar, alphaTyVars, isEmptyTyVarSet )
119
import UniqFM
120
import UniqSet		-- practically all of it
121 122
import Unique		( Unique, mkTupleDataConUnique, pprUnique, showUnique )
import Util		( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
123 124 125 126 127 128
\end{code}

Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
follow.

Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
129
@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
130 131 132 133 134 135
strictness).  The essential info about different kinds of @Ids@ is
in its @IdDetails@.

ToDo: possibly cache other stuff in the single-constructor @Id@ type.

\begin{code}
136 137 138 139 140 141 142 143 144 145 146
data GenId ty = Id
	Unique		-- Key for fast comparison
	ty		-- Id's type; used all the time;
	IdDetails	-- Stuff about individual kinds of Ids.
	PragmaInfo	-- Properties of this Id requested by programmer
			-- eg specialise-me, inline-me
	IdInfo		-- Properties of this Id deduced by compiler
				   
type Id = GenId Type

data StrictnessMark = MarkedStrict | NotMarkedStrict
147 148 149 150 151 152 153 154 155 156 157 158

data IdDetails

  ---------------- Local values

  = LocalId	ShortName	-- mentioned by the user
		Bool		-- True <=> no free type vars

  | SysLocalId	ShortName	-- made up by the compiler
		Bool		-- as for LocalId

  | SpecPragmaId ShortName	-- introduced by the compiler
159 160
		 (Maybe Id)	-- for explicit specid in pragma
		 Bool		-- as for LocalId
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177

  ---------------- Global values

  | ImportedId	FullName	-- Id imported from an interface

  | PreludeId	FullName	-- things < Prelude that compiler "knows" about

  | TopLevId	FullName	-- Top-level in the orig source pgm
				-- (not moved there by transformations).

	-- a TopLevId's type may contain free type variables, if
	-- the monomorphism restriction applies.

  ---------------- Data constructors

  | DataConId	FullName
		ConTag
178
		[StrictnessMark] -- Strict args; length = arity
179

180 181 182 183
		[TyVar] [(Class,Type)] [Type] TyCon
				-- the type is:
				-- forall tyvars . theta_ty =>
				--    unitype_1 -> ... -> unitype_n -> tycon tyvars
184 185 186 187 188 189 190 191 192

  | TupleConId	Int		-- Its arity

  ---------------- Things to do with overloading

  | SuperDictSelId		-- Selector for superclass dictionary
		Class		-- The class (input dict)
		Class		-- The superclass (result dict)

193
  | MethodSelId	Class		-- An overloaded class operation, with
194 195 196 197 198
				-- a fully polymorphic type.  Its code
				-- just selects a method from the
				-- dictionary.  The class.
		ClassOp		-- The operation

199
	-- NB: The IdInfo for a MethodSelId has all the info about its
200 201 202 203
	-- related "constant method Ids", which are just
	-- specialisations of this general one.

  | DefaultMethodId		-- Default method for a particular class op
204
		Class		-- same class, <blah-blah> info as MethodSelId
205 206 207 208
		ClassOp		-- (surprise, surprise)
		Bool		-- True <=> I *know* this default method Id
				-- is a generated one that just says
				-- `error "No default method for <op>"'.
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249

				-- see below
  | DictFunId	Class		-- A DictFun is uniquely identified
		Type		-- by its class and type; this type has free type vars,
				-- whose identity is irrelevant.  Eg Class = Eq
				--				     Type  = Tree a
				-- The "a" is irrelevant.  As it is too painful to
				-- actually do comparisons that way, we kindly supply
				-- a Unique for that purpose.
		Bool		-- True <=> from an instance decl in this mod
		FAST_STRING	-- module where instance came from

				-- see below
  | ConstMethodId		-- A method which depends only on the type of the
				-- instance, and not on any further dictionaries etc.
		Class		-- Uniquely identified by:
		Type		-- (class, type, classop) triple
		ClassOp
		Bool		-- True <=> from an instance decl in this mod
		FAST_STRING	-- module where instance came from

  | InstId	ShortName	-- An instance of a dictionary, class operation,
				-- or overloaded value

  | SpecId			-- A specialisation of another Id
		Id		-- Id of which this is a specialisation
		[Maybe Type]	-- Types at which it is specialised;
				-- A "Nothing" says this type ain't relevant.
		Bool		-- True <=> no free type vars; it's not enough
				-- to know about the unspec version, because
				-- we may specialise to a type w/ free tyvars
				-- (i.e., in one of the "Maybe Type" dudes).

  | WorkerId			-- A "worker" for some other Id
		Id		-- Id for which this is a worker


type ConTag	= Int
type DictVar	= Id
type DictFun	= Id
type DataCon	= Id
250 251
\end{code}

252

253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
DictFunIds are generated from instance decls.
\begin{verbatim}
	class Foo a where
	  op :: a -> a -> Bool

	instance Foo a => Foo [a] where
	  op = ...
\end{verbatim}
generates the dict fun id decl
\begin{verbatim}
	dfun.Foo.[*] = \d -> ...
\end{verbatim}
The dfun id is uniquely named by the (class, type) pair.  Notice, it
isn't a (class,tycon) pair any more, because we may get manually or
automatically generated specialisations of the instance decl:
\begin{verbatim}
	instance Foo [Int] where
	  op = ...
\end{verbatim}
generates
\begin{verbatim}
274
	dfun.Foo.[Int] = ...
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
\end{verbatim}
The type variables in the name are irrelevant; we print them as stars.


Constant method ids are generated from instance decls where
there is no context; that is, no dictionaries are needed to
construct the method.  Example
\begin{verbatim}
	instance Foo Int where
	  op = ...
\end{verbatim}
Then we get a constant method
\begin{verbatim}
	Foo.op.Int = ...
\end{verbatim}

It is possible, albeit unusual, to have a constant method
for an instance decl which has type vars:
\begin{verbatim}
	instance Foo [a] where
	  op []     ys = True
	  op (x:xs) ys = False
\end{verbatim}
We get the constant method
\begin{verbatim}
	Foo.op.[*] = ...
\end{verbatim}
So a constant method is identified by a class/op/type triple.
The type variables in the type are irrelevant.


For Ids whose names must be known/deducible in other modules, we have
to conjure up their worker's names (and their worker's worker's
names... etc) in a known systematic way.

310

311 312 313 314 315 316 317 318 319
%************************************************************************
%*									*
\subsection[Id-documentation]{Documentation}
%*									*
%************************************************************************

[A BIT DATED [WDP]]

The @Id@ datatype describes {\em values}.  The basic things we want to
320
know: (1)~a value's {\em type} (@idType@ is a very common
321 322 323 324 325 326 327 328
operation in the compiler); and (2)~what ``flavour'' of value it might
be---for example, it can be terribly useful to know that a value is a
class method.

\begin{description}
%----------------------------------------------------------------------
\item[@DataConId@:] For the data constructors declared by a @data@
declaration.  Their type is kept in {\em two} forms---as a regular
329
@Type@ (in the usual place), and also in its constituent pieces (in
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
the ``details''). We are frequently interested in those pieces.

%----------------------------------------------------------------------
\item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
the infinite family of tuples.

%----------------------------------------------------------------------
\item[@ImportedId@:] These are values defined outside this module.
{\em Everything} we want to know about them must be stored here (or in
their @IdInfo@).

%----------------------------------------------------------------------
\item[@PreludeId@:] ToDo

%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
@FullName@).  It does {\em not} include those which are moved to the
top-level through program transformations.

We also guarantee that @TopLevIds@ will {\em stay} at top-level.
Theoretically, they could be floated inwards, but there's no known
advantage in doing so.	This way, we can keep them with the same
@Unique@ throughout (no cloning), and, in general, we don't have to be
so paranoid about them.

In particular, we had the following problem generating an interface:
We have to ``stitch together'' info (1)~from the typechecker-produced
global-values list (GVE) and (2)~from the STG code [which @Ids@ have
what arities].	If the @Uniques@ on the @TopLevIds@ can {\em change}
between (1) and (2), you're sunk!

%----------------------------------------------------------------------
363
\item[@MethodSelId@:] A selector from a dictionary; it may select either
364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412
a method or a dictionary for one of the class's superclasses.

%----------------------------------------------------------------------
\item[@DictFunId@:]

@mkDictFunId [a,b..] theta C T@ is the function derived from the
instance declaration

	instance theta => C (T a b ..) where
		...

It builds function @Id@ which maps dictionaries for theta,
to a dictionary for C (T a b ..).

*Note* that with the ``Mark Jones optimisation'', the theta may
include dictionaries for the immediate superclasses of C at the type
(T a b ..).

%----------------------------------------------------------------------
\item[@InstId@:]

%----------------------------------------------------------------------
\item[@SpecId@:]

%----------------------------------------------------------------------
\item[@WorkerId@:]

%----------------------------------------------------------------------
\item[@LocalId@:] A purely-local value, e.g., a function argument,
something defined in a @where@ clauses, ... --- but which appears in
the original program text.

%----------------------------------------------------------------------
\item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
the original program text; these are introduced by the compiler in
doing its thing.

%----------------------------------------------------------------------
\item[@SpecPragmaId@:] Introduced by the compiler to record
Specialisation pragmas. It is dead code which MUST NOT be removed
before specialisation.
\end{description}

Further remarks:
\begin{enumerate}
%----------------------------------------------------------------------
\item

@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
413
@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434
properties:
\begin{itemize}
\item
They have no free type variables, so if you are making a
type-variable substitution you don't need to look inside them.
\item
They are constants, so they are not free variables.  (When the STG
machine makes a closure, it puts all the free variables in the
closure; the above are not required.)
\end{itemize}
Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
properties, but they may not.
\end{enumerate}

%************************************************************************
%*									*
\subsection[Id-general-funs]{General @Id@-related functions}
%*									*
%************************************************************************

\begin{code}
435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453
unsafeGenId2Id :: GenId ty -> Id
unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i

isDataCon id = is_data (unsafeGenId2Id id)
 where
  is_data (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
  is_data (Id _ _ (TupleConId _) _ _)		 = True
  is_data (Id _ _ (SpecId unspec _ _) _ _)	 = is_data unspec
  is_data other					 = False


isTupleCon id = is_tuple (unsafeGenId2Id id)
 where
  is_tuple (Id _ _ (TupleConId _) _ _)		 = True
  is_tuple (Id _ _ (SpecId unspec _ _) _ _)	 = is_tuple unspec
  is_tuple other				 = False

{-LATER:
isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
454 455 456 457 458
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    Just (unspec, ty_maybes)
isSpecId_maybe other_id
  = Nothing

459 460
isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
  = Just specid
461 462
isSpecPragmaId_maybe other_id
  = Nothing
463
-}
464 465 466 467 468 469 470 471 472 473 474 475
\end{code}

@toplevelishId@ tells whether an @Id@ {\em may} be defined in a
nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
defined at top level (returns @True@).	This is used to decide whether
the @Id@ is a candidate free variable.	NB: you are only {\em sure}
about something if it returns @True@!

\begin{code}
toplevelishId	    :: Id -> Bool
idHasNoFreeTyVars   :: Id -> Bool

476
toplevelishId (Id _ _ details _ _)
477 478
  = chk details
  where
479 480 481 482 483 484
    chk (DataConId _ _ _ _ _ _ _) = True
    chk (TupleConId _)	    	  = True
    chk (ImportedId _)	    	  = True
    chk (PreludeId  _)	    	  = True
    chk (TopLevId   _)	    	  = True	-- NB: see notes
    chk (SuperDictSelId _ _)	  = True
485
    chk (MethodSelId _ _)	  = True
486 487
    chk (DefaultMethodId _ _ _)   = True
    chk (DictFunId     _ _ _ _)	  = True
488
    chk (ConstMethodId _ _ _ _ _) = True
489
    chk (SpecId unspec _ _)	  = toplevelishId unspec
490
				  -- depends what the unspecialised thing is
491 492 493 494 495 496 497
    chk (WorkerId unwrkr)	  = toplevelishId unwrkr
    chk (InstId _)		  = False	-- these are local
    chk (LocalId      _ _)	  = False
    chk (SysLocalId   _ _)	  = False
    chk (SpecPragmaId _ _ _)	  = False

idHasNoFreeTyVars (Id _ _ details _ info)
498 499
  = chk details
  where
500 501 502 503 504 505
    chk (DataConId _ _ _ _ _ _ _) = True
    chk (TupleConId _)	    	  = True
    chk (ImportedId _)	    	  = True
    chk (PreludeId  _)	    	  = True
    chk (TopLevId   _)	    	  = True
    chk (SuperDictSelId _ _)	  = True
506
    chk (MethodSelId _ _)	  = True
507 508
    chk (DefaultMethodId _ _ _)   = True
    chk (DictFunId     _ _ _ _)	  = True
509
    chk (ConstMethodId _ _ _ _ _) = True
510 511
    chk (WorkerId unwrkr)	  = idHasNoFreeTyVars unwrkr
    chk (InstId _)		  = False	-- these are local
512 513 514 515 516 517 518
    chk (SpecId _     _   no_free_tvs) = no_free_tvs
    chk (LocalId      _   no_free_tvs) = no_free_tvs
    chk (SysLocalId   _   no_free_tvs) = no_free_tvs
    chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
\end{code}

\begin{code}
519 520 521 522 523
isTopLevId (Id _ _ (TopLevId _) _ _) = True
isTopLevId other		     = False

isImportedId (Id _ _ (ImportedId _) _ _) = True
isImportedId other		  	 = False
524

525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560
isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
			-- LATER: bottomIsGuaranteed (getInfo info)

isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
isSysLocalId other			   = False

isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
isSpecPragmaId other			         = False

isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
isMethodSelId _				 = False

isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
isDefaultMethodId other				       = False

isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
  = Just (cls, clsop, err)
isDefaultMethodId_maybe other = Nothing

isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
isDictFunId other		    	     = False

isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
isConstMethodId other		    		       = False

isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
  = Just (cls, ty, clsop)
isConstMethodId_maybe other = Nothing

isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
isSuperDictSelId_maybe other_id				  = Nothing

isWorkerId (Id _ _ (WorkerId _) _ _) = True
isWorkerId other		     = False

{-LATER:
561
isWrapperId id = workerExists (getIdStrictness id)
562
-}
563 564 565
\end{code}

\begin{code}
566
{-LATER:
567 568 569 570
pprIdInUnfolding :: IdSet -> Id -> Pretty

pprIdInUnfolding in_scopes v
  = let
571
	v_ty = idType v
572 573 574
    in
    -- local vars first:
    if v `elementOfUniqSet` in_scopes then
575
	pprUnique (getItsUnique v)
576 577 578 579 580 581 582 583 584 585

    -- ubiquitous Ids with special syntax:
    else if v == nilDataCon then
	ppPStr SLIT("_NIL_")
    else if isTupleCon v then
	ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))

    -- ones to think about:
    else
	let
586
	    (Id _ _ v_details _ _) = v
587 588 589 590 591 592 593 594
	in
    	case v_details of
	    -- these ones must have been exported by their original module
	  ImportedId   _ -> pp_full_name
	  PreludeId    _ -> pp_full_name

	    -- these ones' exportedness checked later...
	  TopLevId  _ -> pp_full_name
595
	  DataConId _ _ _ _ _ _ _ -> pp_full_name
596 597 598 599

	    -- class-ish things: class already recorded as "mentioned"
	  SuperDictSelId c sc
	    -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
600
	  MethodSelId c o
601 602 603 604 605 606
	    -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
	  DefaultMethodId c o _
	    -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]

	    -- instance-ish things: should we try to figure out
	    -- *exactly* which extra instances have to be exported? (ToDo)
607
	  DictFunId  c t _ _
608
	    -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
609
	  ConstMethodId c t o _ _
610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648
	    -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]

	  -- specialisations and workers
	  SpecId unspec ty_maybes _
	    -> let
		  pp = pprIdInUnfolding in_scopes unspec
	       in
	       ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
			ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
			ppRbrack]

	  WorkerId unwrkr
	    -> let
		  pp = pprIdInUnfolding in_scopes unwrkr
	       in
	       ppBeside (ppPStr SLIT("_WRKR_ ")) pp

	  -- anything else? we're nae interested
	  other_id -> panic "pprIdInUnfolding:mystery Id"
  where
    ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")

    pp_full_name
      = let
	    (m_str, n_str) = getOrigName v

	    pp_n =
	      if isAvarop n_str || isAconop n_str then
		  ppBesides [ppLparen, ppPStr n_str, ppRparen]
	      else
		  ppPStr n_str
	in
	if fromPreludeCore v then
	    pp_n
	else
	    ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]

    pp_class :: Class -> Pretty
    pp_class_op :: ClassOp -> Pretty
649 650
    pp_type :: Type -> Pretty
    pp_ty_maybe :: Maybe Type -> Pretty
651 652 653 654 655 656 657 658

    pp_class    clas = ppr ppr_Unfolding clas
    pp_class_op op   = ppr ppr_Unfolding op

    pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]

    pp_ty_maybe Nothing  = ppPStr SLIT("_N_")
    pp_ty_maybe (Just t) = pp_type t
659
-}
660 661 662 663 664 665 666 667
\end{code}

@whatsMentionedInId@ ferrets out the types/classes/instances on which
this @Id@ depends.  If this Id is to appear in an interface, then
those entities had Jolly Well be in scope.  Someone else up the
call-tree decides that.

\begin{code}
668
{-LATER:
669 670 671 672 673 674 675
whatsMentionedInId
	:: IdSet			    -- Ids known to be in scope
	-> Id				    -- Id being processed
	-> (Bag Id, Bag TyCon, Bag Class)   -- mentioned Ids/TyCons/etc.

whatsMentionedInId in_scopes v
  = let
676
	v_ty = idType v
677 678

    	(tycons, clss)
679
	  = getMentionedTyConsAndClassesFromType v_ty
680 681 682 683 684 685 686 687 688 689 690 691 692 693 694

	result0 id_bag = (id_bag, tycons, clss)

	result1 ids tcs cs
	  = (ids `unionBags` unitBag v,	-- we add v to "mentioned"...
	     tcs `unionBags` tycons,
	     cs  `unionBags` clss)
    in
    -- local vars first:
    if v `elementOfUniqSet` in_scopes then
	result0 emptyBag    -- v not added to "mentioned"

    -- ones to think about:
    else
	let
695
	    (Id _ _ v_details _ _) = v
696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711
	in
    	case v_details of
	  -- specialisations and workers
	  SpecId unspec ty_maybes _
	    -> let
		  (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
	       in
	       result1 ids2 tcs2 cs2

	  WorkerId unwrkr
	    -> let
		  (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
	       in
	       result1 ids2 tcs2 cs2

	  anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
712
-}
713 714 715 716
\end{code}

Tell them who my wrapper function is.
\begin{code}
717
{-LATER:
718 719
myWrapperMaybe :: Id -> Maybe Id

720 721 722
myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
myWrapperMaybe other_id			    	  = Nothing
-}
723 724 725 726 727 728 729 730
\end{code}

\begin{code}
unfoldingUnfriendlyId	-- return True iff it is definitely a bad
	:: Id		-- idea to export an unfolding that
	-> Bool		-- mentions this Id.  Reason: it cannot
			-- possibly be seen in another module.

731 732 733
unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
{-LATER:

734 735 736 737
unfoldingUnfriendlyId id
  | not (externallyVisibleId id) -- that settles that...
  = True

738
unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
739 740 741 742 743 744 745 746
  = class_thing wrapper
  where
    -- "class thing": If we're going to use this worker Id in
    -- an interface, we *have* to be able to untangle the wrapper's
    -- strictness when reading it back in.  At the moment, this
    -- is not always possible: in precisely those cases where
    -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".

747 748 749
    class_thing (Id _ _ (SuperDictSelId _ _) _ _)    = True
    class_thing (Id _ _ (MethodSelId _ _) _ _)  	   = True
    class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
750 751
    class_thing other				   = False

752
unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
753 754 755 756 757 758 759 760
    -- a SPEC of a DictFunId can end up w/ gratuitous
    -- TyVar(Templates) in the i/face; only a problem
    -- if -fshow-pragma-name-errs; but we can do without the pain.
    -- A HACK in any case (WDP 94/05/02)
  = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
    naughty_DictFunId dfun
    --)

761
unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
762 763 764 765 766 767 768 769 770
  = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
    naughty_DictFunId dfun -- similar deal...
    --)

unfoldingUnfriendlyId other_id   = False -- is friendly in all other cases

naughty_DictFunId :: IdDetails -> Bool
    -- True <=> has a TyVar(Template) in the "type" part of its "name"

771 772
naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
naughty_DictFunId (DictFunId _ ty _ _)
773
  = not (isGroundTy ty)
774
-}
775 776 777 778 779 780 781 782 783 784 785 786 787
\end{code}

@externallyVisibleId@: is it true that another module might be
able to ``see'' this Id?

We need the @toplevelishId@ check as well as @isExported@ for when we
compile instance declarations in the prelude.  @DictFunIds@ are
``exported'' if either their class or tycon is exported, but, in
compiling the prelude, the compiler may not recognise that as true.

\begin{code}
externallyVisibleId :: Id -> Bool

788 789 790 791
externallyVisibleId id = panic "Id.externallyVisibleId"
{-LATER:

externallyVisibleId id@(Id _ _ details _ _)
792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807
  = if isLocallyDefined id then
	toplevelishId id && isExported id && not (weird_datacon details)
    else
	not (weird_tuplecon details)
	-- if visible here, it must be visible elsewhere, too.
  where
    -- If it's a DataCon, it's not enough to know it (meaning
    -- its TyCon) is exported; we need to know that it might
    -- be visible outside.  Consider:
    --
    --	data Foo a = Mumble | BigFoo a WeirdLocalType
    --
    -- We can't tell the outside world *anything* about Foo, because
    -- of WeirdLocalType; but we need to know this when asked if
    -- "Mumble" is externally visible...

808
    weird_datacon (DataConId _ _ _ _ _ _ tycon)
809 810 811 812 813 814
      = maybeToBool (maybePurelyLocalTyCon tycon)
    weird_datacon not_a_datacon_therefore_not_weird = False

    weird_tuplecon (TupleConId arity)
      = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
    weird_tuplecon _ = False
815
-}
816 817 818 819 820 821
\end{code}

\begin{code}
idWantsToBeINLINEd :: Id -> Bool

idWantsToBeINLINEd id
822 823
  = panic "Id.idWantsToBeINLINEd"
{- LATER:
824 825 826
  = case (getIdUnfolding id) of
      IWantToBeINLINEd _ -> True
      _ -> False
827
-}
828 829 830 831 832 833
\end{code}

For @unlocaliseId@: See the brief commentary in
\tr{simplStg/SimplStg.lhs}.

\begin{code}
834
{-LATER:
835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863
unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id

unlocaliseId mod (Id u ty info (TopLevId fn))
  = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))

unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
  = --false?: ASSERT(no_ftvs)
    let
	full_name = unlocaliseShortName mod u sn
    in
    Just (Id u ty info (TopLevId full_name))

unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
  = --false?: on PreludeGlaST: ASSERT(no_ftvs)
    let
	full_name = unlocaliseShortName mod u sn
    in
    Just (Id u ty info (TopLevId full_name))

unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
  = case unlocalise_parent mod u unspec of
      Nothing -> Nothing
      Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))

unlocaliseId mod (Id u ty info (WorkerId unwrkr))
  = case unlocalise_parent mod u unwrkr of
      Nothing -> Nothing
      Just xx -> Just (Id u ty info (WorkerId xx))

864
unlocaliseId mod (Id u ty info (InstId name))
865 866 867 868
  = Just (Id u ty info (TopLevId full_name))
	-- type might be wrong, but it hardly matters
	-- at this stage (just before printing C)  ToDo
  where
869 870
    name = getLocalName name
    full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893

unlocaliseId mod other_id = Nothing

--------------------
-- we have to be Very Careful for workers/specs of
-- local functions!

unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
  = --false?: ASSERT(no_ftvs)
    let
	full_name = unlocaliseShortName mod uniq sn
    in
    Just (Id uniq ty info (TopLevId full_name))

unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
  = --false?: ASSERT(no_ftvs)
    let
	full_name = unlocaliseShortName mod uniq sn
    in
    Just (Id uniq ty info (TopLevId full_name))

unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
  -- we're OK otherwise
894
-}
895 896 897 898 899 900 901 902 903 904
\end{code}

CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
`Top-levelish Ids'' cannot have any free type variables, so applying
the type-env cannot have any effect.  (NB: checked in CoreLint?)

The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
former ``should be'' the usual crunch point.

\begin{code}
905
{-LATER:
906 907 908 909 910 911 912 913 914
applyTypeEnvToId :: TypeEnv -> Id -> Id

applyTypeEnvToId type_env id@(Id u ty info details)
  | idHasNoFreeTyVars id
  = id
  | otherwise
  = apply_to_Id ( \ ty ->
	applyTypeEnvToTy type_env ty
    ) id
915
-}
916 917 918
\end{code}

\begin{code}
919 920
{-LATER:
apply_to_Id :: (Type -> Type)
921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950
	    -> Id
	    -> Id

apply_to_Id ty_fn (Id u ty info details)
  = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
  where
    apply_to_details (InstId inst)
      = let
	    new_inst = apply_to_Inst ty_fn inst
	in
	InstId new_inst

    apply_to_details (SpecId unspec ty_maybes no_ftvs)
      = let
	    new_unspec = apply_to_Id ty_fn unspec
	    new_maybes = map apply_to_maybe ty_maybes
	in
	SpecId new_unspec new_maybes no_ftvs
	-- ToDo: recalc no_ftvs????
      where
	apply_to_maybe Nothing   = Nothing
	apply_to_maybe (Just ty) = Just (ty_fn ty)

    apply_to_details (WorkerId unwrkr)
      = let
	    new_unwrkr = apply_to_Id ty_fn unwrkr
	in
	WorkerId new_unwrkr

    apply_to_details other = other
951
-}
952 953 954 955 956 957 958 959 960
\end{code}

Sadly, I don't think the one using the magic typechecker substitution
can be done with @apply_to_Id@.  Here we go....

Strictness is very important here.  We can't leave behind thunks
with pointers to the substitution: it {\em must} be single-threaded.

\begin{code}
961
{-LATER:
962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978
applySubstToId :: Subst -> Id -> (Subst, Id)

applySubstToId subst id@(Id u ty info details)
  -- *cannot* have a "idHasNoFreeTyVars" get-out clause
  -- because, in the typechecker, we are still
  -- *concocting* the types.
  = case (applySubstToTy     subst ty)		of { (s2, new_ty)      ->
    case (applySubstToIdInfo s2    info)	of { (s3, new_info)    ->
    case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
    (s4, Id u new_ty new_info new_details) }}}
  where
    apply_to_details subst _ (InstId inst)
      = case (applySubstToInst subst inst) of { (s2, new_inst) ->
	(s2, InstId new_inst) }

    apply_to_details subst new_ty (SpecId unspec ty_maybes _)
      = case (applySubstToId subst unspec)  	     of { (s2, new_unspec) ->
979
	case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
980 981 982 983 984 985 986 987 988 989
	(s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
	-- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
      where
	apply_to_maybe subst Nothing   = (subst, Nothing)
	apply_to_maybe subst (Just ty)
	  = case (applySubstToTy subst ty) of { (s2, new_ty) ->
	    (s2, Just new_ty) }

    apply_to_details subst _ (WorkerId unwrkr)
      = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
990
	(s2, WorkerId new_unwrkr) }
991 992

    apply_to_details subst _ other = (subst, other)
993
-}
994 995 996
\end{code}

\begin{code}
997 998 999 1000 1001 1002 1003
getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
getIdNamePieces show_uniqs id
  = get (unsafeGenId2Id id)
  where
  get (Id u _ details _ _)
    = case details of
      DataConId n _ _ _ _ _ _ ->
1004 1005 1006
	case (getOrigName n) of { (mod, name) ->
	if fromPrelude mod then [name] else [mod, name] }

1007 1008
      TupleConId 0 -> [SLIT("()")]
      TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
1009

1010 1011 1012
      ImportedId n -> get_fullname_pieces n
      PreludeId  n -> get_fullname_pieces n
      TopLevId   n -> get_fullname_pieces n
1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027

      SuperDictSelId c sc ->
	case (getOrigName c)	of { (c_mod, c_name) ->
	case (getOrigName sc)	of { (sc_mod, sc_name) ->
	let
	    c_bits = if fromPreludeCore c
		     then [c_name]
		     else [c_mod, c_name]

	    sc_bits= if fromPreludeCore sc
		     then [sc_name]
		     else [sc_mod, sc_name]
	in
	[SLIT("sdsel")] ++ c_bits ++ sc_bits  }}

1028
      MethodSelId clas op ->
1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040
	case (getOrigName clas)	of { (c_mod, c_name) ->
	case (getClassOpString op)	of { op_name ->
	if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
	} }

      DefaultMethodId clas op _ ->
	case (getOrigName clas)		of { (c_mod, c_name) ->
	case (getClassOpString op)	of { op_name ->
	if fromPreludeCore clas
	then [SLIT("defm"), op_name]
	else [SLIT("defm"), c_mod, c_name, op_name] }}

1041
      DictFunId c ty _ _ ->
1042 1043 1044 1045 1046
	case (getOrigName c)	    of { (c_mod, c_name) ->
	let
	    c_bits = if fromPreludeCore c
		     then [c_name]
		     else [c_mod, c_name]
1047

1048 1049 1050 1051 1052
	    ty_bits = getTypeString ty
	in
	[SLIT("dfun")] ++ c_bits ++ ty_bits }


1053
      ConstMethodId c ty o _ _ ->
1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066
	case (getOrigName c)	    of { (c_mod, c_name) ->
	case (getTypeString ty)	    of { ty_bits ->
	case (getClassOpString o)   of { o_name ->
	case (if fromPreludeCore c
		then []
		else [c_mod, c_name])	of { c_bits ->
	[SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}

      -- if the unspecialised equiv is "top-level",
      -- the name must be concocted from its name and the
      -- names of the types to which specialised...

      SpecId unspec ty_maybes _ ->
1067 1068 1069
	get unspec ++ (if not (toplevelishId unspec)
		       then [showUnique u]
		       else concat (map typeMaybeString ty_maybes))
1070 1071

      WorkerId unwrkr ->
1072 1073 1074
	get unwrkr ++ (if not (toplevelishId unwrkr)
		       then [showUnique u]
		       else [SLIT("wrk")])
1075 1076

      LocalId      n _   -> let local = getLocalName n in
1077 1078
			    if show_uniqs then [local, showUnique u] else [local]
      InstId       n     -> [getLocalName n, showUnique u]
1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097
      SysLocalId   n _   -> [getLocalName n, showUnique u]
      SpecPragmaId n _ _ -> [getLocalName n, showUnique u]

get_fullname_pieces :: FullName -> [FAST_STRING]
get_fullname_pieces n
  = BIND (getOrigName n) _TO_ (mod, name) ->
    if fromPrelude mod
    then [name]
    else [mod, name]
    BEND
\end{code}

%************************************************************************
%*									*
\subsection[Id-type-funs]{Type-related @Id@ functions}
%*									*
%************************************************************************

\begin{code}
1098 1099 1100
idType :: GenId ty -> ty

idType (Id _ ty _ _ _) = ty
1101 1102 1103
\end{code}

\begin{code}
1104
{-LATER:
1105 1106 1107
getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)

getMentionedTyConsAndClassesFromId id
1108 1109
 = getMentionedTyConsAndClassesFromType (idType id)
-}
1110 1111 1112
\end{code}

\begin{code}
1113
--getIdPrimRep i = primRepFromType (idType i)
1114 1115
\end{code}

1116
\begin{code}
1117
{-LATER:
1118 1119 1120
getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
getInstIdModule other = panic "Id:getInstIdModule"
1121 1122 1123 1124 1125 1126 1127 1128 1129 1130
-}
\end{code}

%************************************************************************
%*									*
\subsection[Id-overloading]{Functions related to overloading}
%*									*
%************************************************************************

\begin{code}
1131 1132 1133
mkSuperDictSelId  u c sc     ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
mkMethodSelId       u c op     ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1134

1135
mkDictFunId u c ity full_ty from_here modname info
1136
  = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
1137

1138
mkConstMethodId	u c op ity full_ty from_here modname info
1139
  = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
1140

1141
mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1142

1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161
mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo

{-LATER:
getConstMethodId clas op ty
  = -- constant-method info is hidden in the IdInfo of
    -- the class-op id (as mentioned up above).
    let
	sel_id = getMethodSelId clas op
    in
    case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
      Just xx -> xx
      Nothing -> error (ppShow 80 (ppAboves [
	ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
	       ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
	       ppr PprDebug sel_id],
	ppStr "(This can arise if an interface pragma refers to an instance",
	ppStr "but there is no imported interface which *defines* that instance.",
	ppStr "The info above, however ugly, should indicate what else you need to import."
	]))
1162 1163 1164 1165 1166 1167 1168 1169 1170 1171
-}
\end{code}

%************************************************************************
%*									*
\subsection[local-funs]{@LocalId@-related functions}
%*									*
%************************************************************************

\begin{code}
1172 1173
mkImported    u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
mkPreludeId   u n ty info = Id u ty (PreludeId  n) NoPragmaInfo info
1174

1175 1176
{-LATER:
updateIdType :: Id -> Type -> Id
1177
updateIdType (Id u _ info details) ty = Id u ty info details
1178
-}
1179 1180 1181
\end{code}

\begin{code}
1182 1183 1184 1185
type MyTy a b = GenType (GenTyVar a) b
type MyId a b = GenId (MyTy a b)

no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1186 1187 1188

-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
1189
mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1190 1191

mkSysLocal str uniq ty loc
1192
  = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1193 1194

mkUserLocal str uniq ty loc
1195 1196 1197
  = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo

-- mkUserId builds a local or top-level Id, depending on the name given
1198
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209
mkUserId (Short uniq short) ty pragma_info
  = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
mkUserId (ValName uniq full) ty pragma_info
  = Id uniq ty 
	(if isLocallyDefined full then TopLevId full else ImportedId full)
	pragma_info noIdInfo
\end{code}


\begin{code}
{-LATER:
1210

1211
-- for a SpecPragmaId being created by the compiler out of thin air...
1212 1213 1214
mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
mkSpecPragmaId str uniq ty specid loc
  = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1215

1216
-- for new SpecId
1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245
mkSpecId u unspec ty_maybes ty info
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))

-- Specialised version of constructor: only used in STG and code generation
-- Note: The specialsied Id has the same unique as the unspeced Id

mkSameSpecCon ty_maybes unspec@(Id u ty info details)
  = ASSERT(isDataCon unspec)
    ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
  where
    new_ty = specialiseTy ty ty_maybes 0

    -- pprTrace "SameSpecCon:Unique:"
    --	        (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))

localiseId :: Id -> Id
localiseId id@(Id u ty info details)
  = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
  where
    name = getOccurrenceName id
    loc  = getSrcLoc id

-- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
-- ToDo: it does??? WDP
mkIdWithNewUniq :: Id -> Unique -> Id

mkIdWithNewUniq (Id _ ty info details) uniq
1246 1247
  = Id uniq ty info new_details
-}
1248 1249 1250 1251 1252 1253
\end{code}

Make some local @Ids@ for a template @CoreExpr@.  These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
\begin{code}
1254 1255
{-LATER:
mkTemplateLocals :: [Type] -> [Id]
1256 1257 1258 1259
mkTemplateLocals tys
  = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
	    (getBuiltinUniques (length tys))
	    tys
1260
-}
1261 1262 1263
\end{code}

\begin{code}
1264 1265
getIdInfo     :: GenId ty -> IdInfo
getPragmaInfo :: GenId ty -> PragmaInfo
1266

1267 1268
getIdInfo     (Id _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ info _) = info
1269

1270
{-LATER:
1271 1272 1273 1274
replaceIdInfo :: Id -> IdInfo -> Id

replaceIdInfo (Id u ty _ details) info = Id u ty info details

1275 1276 1277 1278
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    noIdInfo `addInfo_UF` getIdUnfolding unspec
1279
-}
1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292
\end{code}

%************************************************************************
%*									*
\subsection[Id-arities]{Arity-related functions}
%*									*
%************************************************************************

For locally-defined Ids, the code generator maintains its own notion
of their arities; so it should not be asking...	 (but other things
besides the code-generator need arity info!)

\begin{code}
1293 1294
getIdArity :: Id -> ArityInfo
getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
1295

1296 1297
getDataConArity :: DataCon -> Int
getDataConArity id@(Id _ _ _ _ id_info)
1298 1299 1300 1301 1302 1303
  = ASSERT(isDataCon id)
    case (arityMaybe (getInfo id_info)) of
      Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
      Just  i -> i

addIdArity :: Id -> Int -> Id
1304 1305
addIdArity (Id u ty details pinfo info) arity
  = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1306 1307 1308 1309 1310 1311 1312 1313 1314
\end{code}

%************************************************************************
%*									*
\subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
%*									*
%************************************************************************

\begin{code}
1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325
mkDataCon :: Unique{-DataConKey-}
	  -> FullName
	  -> [StrictnessMark]
	  -> [TyVar] -> ThetaType -> [TauType] -> TyCon
--ToDo:   -> SpecEnv
	  -> Id
  -- can get the tag and all the pieces of the type from the Type

mkDataCon k n stricts tvs ctxt args_tys tycon
  = ASSERT(length stricts == length args_tys)
    data_con
1326
  where
1327 1328 1329 1330 1331 1332 1333 1334
    -- NB: data_con self-recursion; should be OK as tags are not
    -- looked at until late in the game.
    data_con
      = Id k
	   type_of_constructor
	   (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
	   NoPragmaInfo
	   datacon_info
1335

1336
    data_con_tag    = position_within fIRST_TAG data_con_family
1337

1338
    data_con_family = getTyConDataCons tycon
1339

1340
    position_within :: Int -> [Id] -> Int
1341

1342 1343 1344 1345 1346 1347
    position_within acc (c:cs)
      = if c == data_con then acc else position_within (acc+1) cs
#ifdef DEBUG
    position_within acc []
      = panic "mkDataCon: con not found in family"
#endif
1348

1349 1350
    type_of_constructor
      = mkSigmaTy tvs ctxt
1351
	(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1352 1353 1354

    datacon_info = noIdInfo `addInfo_UF` unfolding
			    `addInfo` mkArityInfo arity
1355
--ToDo: 		    `addInfo` specenv
1356 1357 1358 1359

    arity = length args_tys

    unfolding
1360 1361
      = noInfo_UF
{- LATER:
1362 1363 1364 1365
      = -- if arity == 0
    	-- then noIdInfo
	-- else -- do some business...
	let
1366
	    (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1367
	    tyvar_tys = mkTyVarTys tyvars
1368
	in
1369
	BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1370 1371

	mkUnfolding EssentialUnfolding -- for data constructors
1372 1373
		    (mkLam tyvars (dict_vars ++ vars) plain_Con)
	BEND
1374

1375
    mk_uf_bits tvs ctxt arg_tys tycon
1376 1377
      = let
	    (inst_env, tyvars, tyvar_tys)
1378 1379
	      = instantiateTyVarTemplates tvs
					  (map getItsUnique tvs)
1380 1381 1382 1383
	in
	    -- the "context" and "arg_tys" have TyVarTemplates in them, so
	    -- we instantiate those types to have the right TyVars in them
	    -- instead.
1384
	BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1385 1386 1387 1388 1389 1390 1391 1392
						       	_TO_ inst_dict_tys ->
	BIND (map (instantiateTauTy inst_env) arg_tys) 	_TO_ inst_arg_tys ->

	    -- We can only have **ONE** call to mkTemplateLocals here;
	    -- otherwise, we get two blobs of locals w/ mixed-up Uniques
	    -- (Mega-Sigh) [ToDo]
	BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->

1393
	BIND (splitAt (length ctxt) all_vars)	_TO_ (dict_vars, vars) ->
1394 1395 1396 1397

	(tyvars, dict_vars, vars)
	BEND BEND BEND BEND
      where
1398
	-- these are really dubious Types, but they are only to make the
1399 1400
	-- binders for the lambdas for tossed-away dicts.
	ctxt_ty (clas, ty) = mkDictTy clas ty
1401
-}
1402 1403 1404 1405 1406
\end{code}

\begin{code}
mkTupleCon :: Arity -> Id

1407 1408
mkTupleCon arity
  = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info 
1409 1410
  where
    unique      = mkTupleDataConUnique arity
1411 1412
    ty 		= mkSigmaTy tyvars []
		   (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1413 1414
    tycon	= mkTupleTyCon arity
    tyvars	= take arity alphaTyVars
1415
    tyvar_tys	= mkTyVarTys tyvars
1416 1417 1418 1419

    tuplecon_info
      = noIdInfo `addInfo_UF` unfolding
		 `addInfo` mkArityInfo arity
1420
--LATER:?	 `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1421 1422

    unfolding
1423 1424
      = noInfo_UF
{- LATER:
1425 1426 1427 1428 1429
      = -- if arity == 0
    	-- then noIdInfo
	-- else -- do some business...
	let
	    (tyvars, dict_vars, vars) = mk_uf_bits arity
1430
	    tyvar_tys = mkTyVarTys tyvars
1431
	in
1432
	BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1433 1434 1435

	mkUnfolding
	    EssentialUnfolding    -- data constructors
1436 1437
	    (mkLam tyvars (dict_vars ++ vars) plain_Con)
	BEND
1438 1439 1440 1441 1442 1443 1444

    mk_uf_bits arity
      = BIND (mkTemplateLocals tyvar_tys)		 _TO_ vars ->
	(tyvars, [], vars)
	BEND
      where
	tyvar_tmpls	= take arity alphaTyVars
1445 1446
	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
-}
1447 1448 1449 1450 1451 1452 1453

fIRST_TAG :: ConTag
fIRST_TAG =  1	-- Tags allocated from here for real constructors
\end{code}

\begin{code}
getDataConTag :: DataCon -> ConTag	-- will panic if not a DataCon
1454 1455 1456
getDataConTag	(Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
getDataConTag	(Id _ _ (TupleConId _) _ _)	         = fIRST_TAG
getDataConTag	(Id _ _ (SpecId unspec _ _) _ _)	 = getDataConTag unspec
1457 1458

getDataConTyCon :: DataCon -> TyCon	-- will panic if not a DataCon
1459 1460
getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
getDataConTyCon (Id _ _ (TupleConId a) _ _)	           = mkTupleTyCon a
1461

1462
getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1463 1464
					-- will panic if not a DataCon

1465
getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1466 1467
  = (tyvars, theta_ty, arg_tys, tycon)

1468
getDataConSig (Id _ _ (TupleConId arity) _ _)
1469 1470 1471
  = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
  where
    tyvars	= take arity alphaTyVars
1472
    tyvar_tys	= mkTyVarTys tyvars
1473 1474 1475 1476 1477
\end{code}

{- LATER
getDataConTyCon	(Id _ _ _ (SpecId unspec tys _))
  = mkSpecTyCon (getDataConTyCon unspec) tys
1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497

getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
  = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
  where
    (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec

    ty_env = tyvars `zip` ty_maybes

    spec_tyvars = foldr nothing_tyvars [] ty_env
    nothing_tyvars (tyvar, Nothing) l = tyvar : l
    nothing_tyvars (tyvar, Just ty) l = l

    spec_env = foldr just_env [] ty_env
    just_env (tyvar, Nothing) l = l
    just_env (tyvar, Just ty) l = (tyvar, ty) : l
    spec_arg_tys = map (instantiateTauTy spec_env) arg_tys

    spec_theta_ty = if null theta_ty then []
		    else panic "getDataConSig:ThetaTy:SpecDataCon"
    spec_tycon    = mkSpecTyCon tycon ty_maybes
1498
-}
1499 1500
\end{code}

1501
\begin{pseudocode}
1502 1503 1504 1505
@getInstantiatedDataConSig@ takes a constructor and some types to which
it is applied; it returns its signature instantiated to these types.

\begin{code}
1506
getInstantiatedDataConSig ::
1507 1508 1509 1510 1511 1512 1513 1514 1515
	   DataCon	-- The data constructor
			--   Not a specialised data constructor
	-> [TauType]	-- Types to which applied
			--   Must be fully applied i.e. contain all types of tycon
	-> ([TauType],	-- Types of dict args
	    [TauType],	-- Types of regular args
	    TauType	-- Type of result
	   )

1516
getInstantiatedDataConSig data_con inst_tys
1517 1518
  = ASSERT(isDataCon data_con)
    let
1519
	(tvs, theta, arg_tys, tycon) = getDataConSig data_con
1520

1521 1522
	inst_env = ASSERT(length tvs == length inst_tys)
		   tvs `zip` inst_tys
1523

1524 1525 1526
	theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
	cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
	result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
1527 1528