Id.lhs 65.2 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
	idType,
	getIdInfo, replaceIdInfo,
	getPragmaInfo,
35
	idPrimRep, getInstIdModule,
36
	getMentionedTyConsAndClassesFromId,
37

38 39 40 41 42 43
	dataConTag,
	dataConSig, getInstantiatedDataConSig,
	dataConTyCon, dataConArity,
	dataConFieldLabels,

	recordSelectorFieldLabel,
44 45

	-- PREDICATES
46
	isDataCon, isTupleCon,
47 48 49 50 51
	isSpecId_maybe, isSpecPragmaId_maybe,
	toplevelishId, externallyVisibleId,
	isTopLevId, isWorkerId, isWrapperId,
	isImportedId, isSysLocalId,
	isBottomingId,
52 53 54 55
	isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
	isDictFunId,
--???	isInstId_maybe,
	isConstMethodId_maybe,
56 57 58 59 60 61 62 63 64 65 66 67
	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)
68
	getIdArity, addIdArity,
69 70 71
	getIdDemandInfo, addIdDemandInfo,
	getIdSpecialisation, addIdSpecialisation,
	getIdStrictness, addIdStrictness,
72
	getIdUnfolding, addIdUnfolding,
73 74 75 76 77 78 79 80 81 82 83
	getIdUpdateInfo, addIdUpdateInfo,
	getIdArgUsageInfo, addIdArgUsageInfo,
	getIdFBTypeInfo, addIdFBTypeInfo,
	-- don't export the types, lest OptIdInfo be dragged in!

	-- MISCELLANEOUS
	unlocaliseId,
	fIRST_TAG,
	showId,
	pprIdInUnfolding,

84 85 86 87 88 89
	-- "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,
90

91 92 93
	-- and to make the interface self-sufficient...
	GenIdSet(..), IdSet(..)
    )-} where
94

95 96 97 98
import Ubiq
import IdLoop   -- for paranoia checking
import TyLoop   -- for paranoia checking
import NameLoop -- for paranoia checking
99 100

import Bag
101
import Class		( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
102
import CStrings		( identToC, cSEP )
103 104 105
import IdInfo
import Maybes		( maybeToBool )
import NameTypes	( mkShortName, fromPrelude, FullName, ShortName )
106
import FieldLabel	( fieldLabelName, FieldLabel{-instances-} )
107
import Name		( Name(..) )
108 109 110 111
import Outputable	( isAvarop, isAconop, getLocalName,
			  isExported, ExportFlag(..) )
import PragmaInfo	( PragmaInfo(..) )
import PrelMods		( pRELUDE_BUILTIN )
112 113 114
import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
			  GenType, GenTyVar
			)
115 116 117
import PprStyle
import Pretty
import SrcLoc		( mkBuiltinSrcLoc )
118
import TyCon		( TyCon, mkTupleTyCon, tyConDataCons )
119 120
import Type		( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
			  applyTyCon, isPrimType, instantiateTy,
121
			  tyVarsOfType, applyTypeEnvToTy, typePrimRep,
122 123
			  GenType, ThetaType(..), TauType(..), Type(..)
			)
124
import TyVar		( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
125
import UniqFM
126
import UniqSet		-- practically all of it
127 128 129 130 131 132 133
import UniqSupply	( getBuiltinUniques )
import Unique		( mkTupleDataConUnique, pprUnique, showUnique,
			  Unique{-instance Ord3-}
			)
import Util		( mapAccumL, nOfThem,
			  panic, panic#, pprPanic, assertPanic
			)
134 135 136 137 138 139
\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
140
@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
141 142 143 144 145 146
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}
147 148 149 150 151 152 153 154 155 156 157
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
158 159 160 161 162 163 164 165 166 167 168 169

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
170 171
		 (Maybe Id)	-- for explicit specid in pragma
		 Bool		-- as for LocalId
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188

  ---------------- 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
189
		[StrictnessMark] -- Strict args; length = arity
190
		[FieldLabel]	-- Field labels for this constructor
191

192 193 194 195
		[TyVar] [(Class,Type)] [Type] TyCon
				-- the type is:
				-- forall tyvars . theta_ty =>
				--    unitype_1 -> ... -> unitype_n -> tycon tyvars
196 197 198

  | TupleConId	Int		-- Its arity

199 200
  | RecordSelectorId FieldLabel

201 202 203 204 205 206
  ---------------- Things to do with overloading

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

207
  | MethodSelId	Class		-- An overloaded class operation, with
208 209 210 211 212
				-- a fully polymorphic type.  Its code
				-- just selects a method from the
				-- dictionary.  The class.
		ClassOp		-- The operation

213
	-- NB: The IdInfo for a MethodSelId has all the info about its
214 215 216 217
	-- related "constant method Ids", which are just
	-- specialisations of this general one.

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

				-- 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
246
		Bool		-- as for LocalId
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264

  | 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
265 266
\end{code}

267

268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
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}
289
	dfun.Foo.[Int] = ...
290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
\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.

325

326 327 328 329 330 331 332 333 334
%************************************************************************
%*									*
\subsection[Id-documentation]{Documentation}
%*									*
%************************************************************************

[A BIT DATED [WDP]]

The @Id@ datatype describes {\em values}.  The basic things we want to
335
know: (1)~a value's {\em type} (@idType@ is a very common
336 337 338 339 340 341 342 343
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
344
@Type@ (in the usual place), and also in its constituent pieces (in
345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377
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!

%----------------------------------------------------------------------
378
\item[@MethodSelId@:] A selector from a dictionary; it may select either
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 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427
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@,
428
@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
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}
450 451 452 453 454
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
455 456 457 458
  is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
  is_data (Id _ _ (TupleConId _) _ _)		   = True
  is_data (Id _ _ (SpecId unspec _ _) _ _)	   = is_data unspec
  is_data other					   = False
459 460 461 462 463 464 465 466 467 468


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 _) _ _)
469 470 471 472 473
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    Just (unspec, ty_maybes)
isSpecId_maybe other_id
  = Nothing

474 475
isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
  = Just specid
476 477
isSpecPragmaId_maybe other_id
  = Nothing
478
-}
479 480 481 482 483 484 485 486 487 488 489 490
\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

491
toplevelishId (Id _ _ details _ _)
492 493
  = chk details
  where
494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
    chk (DataConId _ _ _ _ _ _ _ _) = True
    chk (TupleConId _)	    	    = True
    chk (RecordSelectorId _)   	    = True
    chk (ImportedId _)	    	    = True
    chk (PreludeId  _)	    	    = True
    chk (TopLevId   _)	    	    = True	-- NB: see notes
    chk (SuperDictSelId _ _)	    = True
    chk (MethodSelId _ _)	    = True
    chk (DefaultMethodId _ _ _)     = True
    chk (DictFunId     _ _ _ _)	    = True
    chk (ConstMethodId _ _ _ _ _)   = True
    chk (SpecId unspec _ _)	    = toplevelishId unspec
				    -- depends what the unspecialised thing is
    chk (WorkerId unwrkr)	    = toplevelishId unwrkr
    chk (InstId _ _)		    = False	-- these are local
    chk (LocalId      _ _)	    = False
    chk (SysLocalId   _ _)	    = False
    chk (SpecPragmaId _ _ _)	    = False
512 513

idHasNoFreeTyVars (Id _ _ details _ info)
514 515
  = chk details
  where
516
    chk (DataConId _ _ _ _ _ _ _ _) = True
517
    chk (TupleConId _)	    	  = True
518
    chk (RecordSelectorId _)   	  = True
519 520 521 522
    chk (ImportedId _)	    	  = True
    chk (PreludeId  _)	    	  = True
    chk (TopLevId   _)	    	  = True
    chk (SuperDictSelId _ _)	  = True
523
    chk (MethodSelId _ _)	  = True
524 525
    chk (DefaultMethodId _ _ _)   = True
    chk (DictFunId     _ _ _ _)	  = True
526
    chk (ConstMethodId _ _ _ _ _) = True
527
    chk (WorkerId unwrkr)	  = idHasNoFreeTyVars unwrkr
528
    chk (InstId       _   no_free_tvs) = no_free_tvs
529 530 531 532 533 534 535
    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}
536 537 538 539 540
isTopLevId (Id _ _ (TopLevId _) _ _) = True
isTopLevId other		     = False

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

542
isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576

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:
577
isWrapperId id = workerExists (getIdStrictness id)
578
-}
579 580 581
\end{code}

\begin{code}
582
{-LATER:
583 584 585 586
pprIdInUnfolding :: IdSet -> Id -> Pretty

pprIdInUnfolding in_scopes v
  = let
587
	v_ty = idType v
588 589 590
    in
    -- local vars first:
    if v `elementOfUniqSet` in_scopes then
591
	pprUnique (getItsUnique v)
592 593 594 595 596

    -- ubiquitous Ids with special syntax:
    else if v == nilDataCon then
	ppPStr SLIT("_NIL_")
    else if isTupleCon v then
597
	ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
598 599 600 601

    -- ones to think about:
    else
	let
602
	    (Id _ _ v_details _ _) = v
603 604 605 606 607 608 609 610
	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
611 612 613
	  DataConId _ _ _ _ _ _ _ _ -> pp_full_name

	  RecordSelectorId lbl -> ppr sty lbl
614 615 616 617

	    -- class-ish things: class already recorded as "mentioned"
	  SuperDictSelId c sc
	    -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
618
	  MethodSelId c o
619 620 621 622 623 624
	    -> 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)
625
	  DictFunId  c t _ _
626
	    -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
627
	  ConstMethodId c t o _ _
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666
	    -> 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
667 668
    pp_type :: Type -> Pretty
    pp_ty_maybe :: Maybe Type -> Pretty
669 670 671 672 673 674 675 676

    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
677
-}
678 679 680 681 682 683 684 685
\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}
686
{-LATER:
687 688 689 690 691 692 693
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
694
	v_ty = idType v
695 696

    	(tycons, clss)
697
	  = getMentionedTyConsAndClassesFromType v_ty
698 699 700 701 702 703 704 705 706 707 708 709 710 711 712

	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
713
	    (Id _ _ v_details _ _) = v
714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729
	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"
730
-}
731 732 733 734
\end{code}

Tell them who my wrapper function is.
\begin{code}
735
{-LATER:
736 737
myWrapperMaybe :: Id -> Maybe Id

738 739 740
myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
myWrapperMaybe other_id			    	  = Nothing
-}
741 742 743 744 745 746 747 748
\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.

749 750 751
unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
{-LATER:

752 753 754 755
unfoldingUnfriendlyId id
  | not (externallyVisibleId id) -- that settles that...
  = True

756
unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
757 758 759 760 761 762 763 764
  = 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".

765 766 767
    class_thing (Id _ _ (SuperDictSelId _ _) _ _)    = True
    class_thing (Id _ _ (MethodSelId _ _) _ _)  	   = True
    class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
768 769
    class_thing other				   = False

770
unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
771 772 773 774
    -- 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)
775
  = naughty_DictFunId dfun
776

777
unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
778
  = naughty_DictFunId dfun -- similar deal...
779 780 781 782 783 784

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"

785 786
naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
naughty_DictFunId (DictFunId _ ty _ _)
787
  = not (isGroundTy ty)
788
-}
789 790 791 792 793 794 795 796 797 798 799 800 801
\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

802
externallyVisibleId id@(Id _ _ details _ _)
803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818
  = 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...

819 820
{- LATER: if at all:
    weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
821
      = maybeToBool (maybePurelyLocalTyCon tycon)
822
-}
823 824 825 826 827 828 829 830 831 832
    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
\end{code}

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

833 834
idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
idWantsToBeINLINEd _				 = False
835 836 837 838 839 840
\end{code}

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

\begin{code}
841
{-LATER:
842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870
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))

871
unlocaliseId mod (Id u ty info (InstId name no_ftvs))
872 873 874 875
  = 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
876 877
    name = getLocalName name
    full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900

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
901
-}
902 903 904 905 906 907 908 909 910 911
\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}
912 913
type TypeEnv = TyVarEnv Type

914 915
applyTypeEnvToId :: TypeEnv -> Id -> Id

916
applyTypeEnvToId type_env id@(Id _ ty _ _ _)
917 918 919 920 921 922 923 924 925
  | idHasNoFreeTyVars id
  = id
  | otherwise
  = apply_to_Id ( \ ty ->
	applyTypeEnvToTy type_env ty
    ) id
\end{code}

\begin{code}
926
apply_to_Id :: (Type -> Type)
927 928 929
	    -> Id
	    -> Id

930 931 932 933 934
apply_to_Id ty_fn (Id u ty details prag info)
  = let
	new_ty = ty_fn ty
    in
    Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
935 936 937 938 939 940
  where
    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
941 942
	SpecId new_unspec new_maybes (no_free_tvs ty)
	-- ToDo: gratuitous recalc no_ftvs???? (also InstId)
943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962
      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
\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}
963
{-LATER:
964 965 966 967 968 969 970 971 972 973 974
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
975
    apply_to_details subst _ (InstId inst no_ftvs)
976
      = case (applySubstToInst subst inst) of { (s2, new_inst) ->
977
	(s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
978 979 980

    apply_to_details subst new_ty (SpecId unspec ty_maybes _)
      = case (applySubstToId subst unspec)  	     of { (s2, new_unspec) ->
981
	case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
982 983 984 985 986 987 988 989 990 991
	(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) ->
992
	(s2, WorkerId new_unwrkr) }
993 994

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

\begin{code}
999
getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1000

1001 1002 1003 1004 1005
getIdNamePieces show_uniqs id
  = get (unsafeGenId2Id id)
  where
  get (Id u _ details _ _)
    = case details of
1006
      DataConId n _ _ _ _ _ _ _ ->
1007 1008 1009
	case (getOrigName n) of { (mod, name) ->
	if fromPrelude mod then [name] else [mod, name] }

1010 1011
      TupleConId 0 -> [SLIT("()")]
      TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
1012

1013 1014
      RecordSelectorId lbl -> panic "getIdNamePieces:RecordSelectorId"

1015 1016 1017
      ImportedId n -> get_fullname_pieces n
      PreludeId  n -> get_fullname_pieces n
      TopLevId   n -> get_fullname_pieces n
1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032

      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  }}

1033
      MethodSelId clas op ->
1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045
	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] }}

1046
      DictFunId c ty _ _ ->
1047 1048 1049 1050 1051
	case (getOrigName c)	    of { (c_mod, c_name) ->
	let
	    c_bits = if fromPreludeCore c
		     then [c_name]
		     else [c_mod, c_name]
1052

1053 1054 1055 1056 1057
	    ty_bits = getTypeString ty
	in
	[SLIT("dfun")] ++ c_bits ++ ty_bits }


1058
      ConstMethodId c ty o _ _ ->
1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071
	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 _ ->
1072 1073 1074
	get unspec ++ (if not (toplevelishId unspec)
		       then [showUnique u]
		       else concat (map typeMaybeString ty_maybes))
1075 1076

      WorkerId unwrkr ->
1077 1078 1079
	get unwrkr ++ (if not (toplevelishId unwrkr)
		       then [showUnique u]
		       else [SLIT("wrk")])
1080 1081

      LocalId      n _   -> let local = getLocalName n in
1082
			    if show_uniqs then [local, showUnique u] else [local]
1083
      InstId       n _   -> [getLocalName n, showUnique u]
1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102
      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}
1103 1104 1105
idType :: GenId ty -> ty

idType (Id _ ty _ _ _) = ty
1106 1107 1108
\end{code}

\begin{code}
1109
{-LATER:
1110 1111 1112
getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)

getMentionedTyConsAndClassesFromId id
1113 1114
 = getMentionedTyConsAndClassesFromType (idType id)
-}
1115 1116 1117
\end{code}

\begin{code}
1118
idPrimRep i = typePrimRep (idType i)
1119 1120
\end{code}

1121
\begin{code}
1122
{-LATER:
1123 1124 1125
getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
getInstIdModule other = panic "Id:getInstIdModule"
1126 1127 1128 1129 1130 1131 1132 1133 1134 1135
-}
\end{code}

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

\begin{code}
1136 1137 1138
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
1139

1140
mkDictFunId u c ity full_ty from_here modname info
1141
  = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
1142

1143
mkConstMethodId	u c op ity full_ty from_here modname info
1144
  = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
1145

1146
mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1147

1148
mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1149 1150 1151 1152 1153 1154 1155 1156 1157 1158

{-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
1159 1160
      Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
	ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1161 1162 1163 1164
	       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."
1165
	])
1166 1167 1168 1169 1170 1171 1172 1173 1174 1175
-}
\end{code}

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

\begin{code}
1176 1177
mkImported    u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
mkPreludeId   u n ty info = Id u ty (PreludeId  n) NoPragmaInfo info
1178

1179 1180
{-LATER:
updateIdType :: Id -> Type -> Id
1181
updateIdType (Id u _ info details) ty = Id u ty info details
1182
-}
1183 1184 1185
\end{code}

\begin{code}
1186 1187 1188 1189
type MyTy a b = GenType (GenTyVar a) b
type MyId a b = GenId (MyTy a b)

no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1190 1191 1192

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

mkSysLocal str uniq ty loc
1196
  = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1197 1198

mkUserLocal str uniq ty loc
1199 1200 1201
  = 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
1202
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213
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:
1214

1215
-- for a SpecPragmaId being created by the compiler out of thin air...
1216 1217 1218
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))
1219

1220
-- for new SpecId
1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240
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

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
1241
-}
1242 1243 1244

mkIdWithNewUniq :: Id -> Unique -> Id

1245 1246
mkIdWithNewUniq (Id _ ty details prag info) uniq
  = Id uniq ty details prag info
1247 1248 1249 1250 1251 1252
\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}
1253
mkTemplateLocals :: [Type] -> [Id]
1254
mkTemplateLocals tys
1255
  = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1256 1257 1258 1259 1260
	    (getBuiltinUniques (length tys))
	    tys
\end{code}

\begin{code}
1261 1262
getIdInfo     :: GenId ty -> IdInfo
getPragmaInfo :: GenId ty -> PragmaInfo
1263

1264 1265
getIdInfo     (Id _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ info _) = info
1266

1267
{-LATER:
1268 1269 1270 1271
replaceIdInfo :: Id -> IdInfo -> Id

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

1272 1273 1274 1275
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    noIdInfo `addInfo_UF` getIdUnfolding unspec
1276
-}
1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289
\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}
1290 1291
getIdArity :: Id -> ArityInfo
getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
1292

1293 1294
dataConArity :: DataCon -> Int
dataConArity id@(Id _ _ _ _ id_info)
1295 1296
  = ASSERT(isDataCon id)
    case (arityMaybe (getInfo id_info)) of
1297
      Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1298 1299 1300
      Just  i -> i

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

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

\begin{code}
1312 1313
mkDataCon :: Unique{-DataConKey-}
	  -> FullName
1314
	  -> [StrictnessMark] -> [FieldLabel]
1315 1316 1317 1318 1319
	  -> [TyVar] -> ThetaType -> [TauType] -> TyCon
--ToDo:   -> SpecEnv
	  -> Id
  -- can get the tag and all the pieces of the type from the Type

1320
mkDataCon k n stricts fields tvs ctxt args_tys tycon
1321 1322
  = ASSERT(length stricts == length args_tys)
    data_con
1323
  where
1324 1325 1326 1327 1328
    -- 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
1329
	   (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1330 1331
	   NoPragmaInfo
	   datacon_info
1332

1333
    data_con_tag    = position_within fIRST_TAG data_con_family
1334

1335
    data_con_family = tyConDataCons tycon
1336

1337
    position_within :: Int -> [Id] -> Int
1338

1339 1340 1341 1342 1343 1344
    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
1345

1346 1347
    type_of_constructor
      = mkSigmaTy tvs ctxt
1348
	(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1349 1350 1351

    datacon_info = noIdInfo `addInfo_UF` unfolding
			    `addInfo` mkArityInfo arity
1352
--ToDo: 		    `addInfo` specenv
1353 1354 1355 1356

    arity = length args_tys

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

	mkUnfolding EssentialUnfolding -- for data constructors
1369 1370
		    (mkLam tyvars (dict_vars ++ vars) plain_Con)
	BEND
1371

1372
    mk_uf_bits tvs ctxt arg_tys tycon
1373 1374
      = let
	    (inst_env, tyvars, tyvar_tys)
1375 1376
	      = instantiateTyVarTemplates tvs
					  (map getItsUnique tvs)
1377 1378 1379 1380
	in
	    -- the "context" and "arg_tys" have TyVarTemplates in them, so
	    -- we instantiate those types to have the right TyVars in them
	    -- instead.
1381
	BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1382 1383 1384 1385 1386 1387 1388 1389
						       	_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 ->

1390
	BIND (splitAt (length ctxt) all_vars)	_TO_ (dict_vars, vars) ->
1391 1392 1393 1394

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

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

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

    tuplecon_info
      = noIdInfo `addInfo_UF` unfolding
		 `addInfo` mkArityInfo arity
1417
--LATER:?	 `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1418 1419

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

	mkUnfolding
	    EssentialUnfolding    -- data constructors
1433 1434
	    (mkLam tyvars (dict_vars ++ vars) plain_Con)
	BEND
1435 1436 1437 1438 1439 1440 1441

    mk_uf_bits arity
      = BIND (mkTemplateLocals tyvar_tys)		 _TO_ vars ->
	(tyvars, [], vars)
	BEND
      where
	tyvar_tmpls	= take arity alphaTyVars
1442 1443
	(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
-}