Id.lhs 61.5 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
	dataConTag, dataConStrictMarks,
	dataConSig, dataConArgTys,
40
41
42
43
	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
	nmbrId,

86
87
88
89
90
91
	-- "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,
92

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

97
98
99
import Ubiq
import IdLoop   -- for paranoia checking
import TyLoop   -- for paranoia checking
100
101

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

data IdDetails

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

170
  = LocalId	Name		-- Local name; mentioned by the user
171
172
		Bool		-- True <=> no free type vars

173
  | SysLocalId	Name	        -- Local name; made up by the compiler
174
175
		Bool		-- as for LocalId

176
  | SpecPragmaId Name		-- Local name; introduced by the compiler
177
178
		 (Maybe Id)	-- for explicit specid in pragma
		 Bool		-- as for LocalId
179
180
181

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

182
  | ImportedId	Name		-- Global name (Imported or Implicit); Id imported from an interface
183

184
  | PreludeId	Name		-- Global name (Builtin);  Builtin prelude Ids
185

186
  | TopLevId	Name		-- Global name (LocalDef); Top-level in the orig source pgm
187
188
189
190
191
192
193
				-- (not moved there by transformations).

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

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

194
  | DataConId	Name
195
		ConTag
196
		[StrictnessMark] -- Strict args; length = arity
197
		[FieldLabel]	-- Field labels for this constructor
198

199
200
201
202
		[TyVar] [(Class,Type)] [Type] TyCon
				-- the type is:
				-- forall tyvars . theta_ty =>
				--    unitype_1 -> ... -> unitype_n -> tycon tyvars
203

204
205
  | TupleConId	Name
		Int		-- Its arity
206

207
  | RecordSelId FieldLabel
208

209
210
211
212
213
214
  ---------------- Things to do with overloading

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

215
  | MethodSelId	Class		-- An overloaded class operation, with
216
217
218
219
220
				-- a fully polymorphic type.  Its code
				-- just selects a method from the
				-- dictionary.  The class.
		ClassOp		-- The operation

221
	-- NB: The IdInfo for a MethodSelId has all the info about its
222
223
224
225
	-- related "constant method Ids", which are just
	-- specialisations of this general one.

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

				-- 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
241
		(Maybe Module)	-- module where instance came from; Nothing => Prelude
242
243
244
245
246
247
248

				-- 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
249
250
		Bool		-- True => from an instance decl in this mod
		(Maybe Module)	-- module where instance came from; Nothing => Prelude
251

252
253
  | InstId	Name		-- An instance of a dictionary, class operation,
				-- or overloaded value (Local name)
254
		Bool		-- as for LocalId
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272

  | 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
273
274
\end{code}

275

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
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}
297
	dfun.Foo.[Int] = ...
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
325
326
327
328
329
330
331
332
\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.

333

334
335
336
337
338
339
340
341
342
%************************************************************************
%*									*
\subsection[Id-documentation]{Documentation}
%*									*
%************************************************************************

[A BIT DATED [WDP]]

The @Id@ datatype describes {\em values}.  The basic things we want to
343
know: (1)~a value's {\em type} (@idType@ is a very common
344
345
346
347
348
349
350
351
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
352
@Type@ (in the usual place), and also in its constituent pieces (in
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
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
370
@Name@).  It does {\em not} include those which are moved to the
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
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!

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


isTupleCon id = is_tuple (unsafeGenId2Id id)
 where
471
  is_tuple (Id _ _ (TupleConId _ _) _ _)	 = True
472
473
474
475
476
  is_tuple (Id _ _ (SpecId unspec _ _) _ _)	 = is_tuple unspec
  is_tuple other				 = False

{-LATER:
isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
477
478
479
480
481
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    Just (unspec, ty_maybes)
isSpecId_maybe other_id
  = Nothing

482
483
isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
  = Just specid
484
485
isSpecPragmaId_maybe other_id
  = Nothing
486
-}
487
488
489
490
491
492
493
494
495
496
497
498
\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

499
toplevelishId (Id _ _ details _ _)
500
501
  = chk details
  where
502
    chk (DataConId _ _ _ _ _ _ _ _) = True
503
504
    chk (TupleConId _ _)    	    = True
    chk (RecordSelId _)   	    = True
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
    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
520
521

idHasNoFreeTyVars (Id _ _ details _ info)
522
523
  = chk details
  where
524
    chk (DataConId _ _ _ _ _ _ _ _) = True
525
526
    chk (TupleConId _ _)    	  = True
    chk (RecordSelId _)   	  = True
527
528
529
530
    chk (ImportedId _)	    	  = True
    chk (PreludeId  _)	    	  = True
    chk (TopLevId   _)	    	  = True
    chk (SuperDictSelId _ _)	  = True
531
    chk (MethodSelId _ _)	  = True
532
533
    chk (DefaultMethodId _ _ _)   = True
    chk (DictFunId     _ _ _ _)	  = True
534
    chk (ConstMethodId _ _ _ _ _) = True
535
    chk (WorkerId unwrkr)	  = idHasNoFreeTyVars unwrkr
536
    chk (InstId       _   no_free_tvs) = no_free_tvs
537
538
539
540
541
542
543
    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}
544
545
546
547
548
isTopLevId (Id _ _ (TopLevId _) _ _) = True
isTopLevId other		     = False

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

550
isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
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
577
578
579
580
581
582
583
584

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:
585
isWrapperId id = workerExists (getIdStrictness id)
586
-}
587
588
589
\end{code}

\begin{code}
590
{-LATER:
591
592
593
594
pprIdInUnfolding :: IdSet -> Id -> Pretty

pprIdInUnfolding in_scopes v
  = let
595
	v_ty = idType v
596
597
598
    in
    -- local vars first:
    if v `elementOfUniqSet` in_scopes then
599
	pprUnique (idUnique v)
600
601
602
603
604

    -- ubiquitous Ids with special syntax:
    else if v == nilDataCon then
	ppPStr SLIT("_NIL_")
    else if isTupleCon v then
605
	ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
606
607
608
609

    -- ones to think about:
    else
	let
610
	    (Id _ _ v_details _ _) = v
611
612
613
614
615
616
617
618
	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
619
620
	  DataConId _ _ _ _ _ _ _ _ -> pp_full_name

621
	  RecordSelId lbl -> ppr sty lbl
622
623
624
625

	    -- class-ish things: class already recorded as "mentioned"
	  SuperDictSelId c sc
	    -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
626
	  MethodSelId c o
627
628
629
630
631
632
	    -> 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)
633
	  DictFunId  c t _ _
634
	    -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
635
	  ConstMethodId c t o _ _
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
	    -> 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
660
	    (m_str, n_str) = moduleNamePair v
661
662

	    pp_n =
663
	      if isLexSym n_str && not (isLexSpecialSym n_str) then
664
665
666
667
		  ppBesides [ppLparen, ppPStr n_str, ppRparen]
	      else
		  ppPStr n_str
	in
668
	if isPreludeDefined v then
669
670
671
672
673
674
	    pp_n
	else
	    ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]

    pp_class :: Class -> Pretty
    pp_class_op :: ClassOp -> Pretty
675
676
    pp_type :: Type -> Pretty
    pp_ty_maybe :: Maybe Type -> Pretty
677
678
679
680
681
682
683
684

    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
685
-}
686
687
688
689
690
691
692
693
\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}
694
{-LATER:
695
696
697
698
699
700
701
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
702
	v_ty = idType v
703
704

    	(tycons, clss)
705
	  = getMentionedTyConsAndClassesFromType v_ty
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720

	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
721
	    (Id _ _ v_details _ _) = v
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
	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"
738
-}
739
740
741
742
\end{code}

Tell them who my wrapper function is.
\begin{code}
743
{-LATER:
744
745
myWrapperMaybe :: Id -> Maybe Id

746
747
748
myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
myWrapperMaybe other_id			    	  = Nothing
-}
749
750
751
752
753
754
755
756
\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.

757
758
759
unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
{-LATER:

760
761
762
763
unfoldingUnfriendlyId id
  | not (externallyVisibleId id) -- that settles that...
  = True

764
unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
765
766
767
768
769
770
771
772
  = 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".

773
774
775
    class_thing (Id _ _ (SuperDictSelId _ _) _ _)    = True
    class_thing (Id _ _ (MethodSelId _ _) _ _)  	   = True
    class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
776
777
    class_thing other				   = False

778
unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
779
780
781
782
    -- 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)
783
  = naughty_DictFunId dfun
784

785
unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
786
  = naughty_DictFunId dfun -- similar deal...
787
788
789
790
791
792

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"

793
794
naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
naughty_DictFunId (DictFunId _ ty _ _)
795
  = not (isGroundTy ty)
796
-}
797
798
799
800
801
802
803
804
805
806
807
808
809
\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

810
externallyVisibleId id@(Id _ _ details _ _)
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
  = 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...

827
828
{- LATER: if at all:
    weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
829
      = maybeToBool (maybePurelyLocalTyCon tycon)
830
-}
831
832
    weird_datacon not_a_datacon_therefore_not_weird = False

833
    weird_tuplecon (TupleConId _ arity)
834
835
836
837
838
839
840
      = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
    weird_tuplecon _ = False
\end{code}

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

841
842
idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
idWantsToBeINLINEd _				 = False
843
844
845
846
847
848
\end{code}

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

\begin{code}
849
{-LATER:
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
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))

879
unlocaliseId mod (Id u ty info (InstId name no_ftvs))
880
881
882
883
  = 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
884
885
    name = getLocalName name
    full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908

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
909
-}
910
911
912
913
914
915
916
917
918
919
\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}
920
921
type TypeEnv = TyVarEnv Type

922
923
applyTypeEnvToId :: TypeEnv -> Id -> Id

924
applyTypeEnvToId type_env id@(Id _ ty _ _ _)
925
926
927
928
929
930
931
932
933
  | idHasNoFreeTyVars id
  = id
  | otherwise
  = apply_to_Id ( \ ty ->
	applyTypeEnvToTy type_env ty
    ) id
\end{code}

\begin{code}
934
apply_to_Id :: (Type -> Type)
935
936
937
	    -> Id
	    -> Id

938
939
940
941
942
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)
943
944
945
946
947
948
  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
949
950
	SpecId new_unspec new_maybes (no_free_tvs ty)
	-- ToDo: gratuitous recalc no_ftvs???? (also InstId)
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
      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}
971
{-LATER:
972
973
974
975
976
977
978
979
980
981
982
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
983
    apply_to_details subst _ (InstId inst no_ftvs)
984
      = case (applySubstToInst subst inst) of { (s2, new_inst) ->
985
	(s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
986
987
988

    apply_to_details subst new_ty (SpecId unspec ty_maybes _)
      = case (applySubstToId subst unspec)  	     of { (s2, new_unspec) ->
989
	case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
990
991
992
993
994
995
996
997
998
999
	(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) ->
1000
	(s2, WorkerId new_unwrkr) }
1001
1002

    apply_to_details subst _ other = (subst, other)
1003
-}
1004
1005
1006
\end{code}

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

1009
1010
1011
1012
1013
getIdNamePieces show_uniqs id
  = get (unsafeGenId2Id id)
  where
  get (Id u _ details _ _)
    = case details of
1014
      DataConId n _ _ _ _ _ _ _ ->
1015
	case (moduleNamePair n) of { (mod, name) ->
1016
	if isPreludeDefinedName n then [name] else [mod, name] }
1017

1018
      TupleConId n _ -> [nameOf (origName n)]
1019

1020
1021
1022
1023
1024
      RecordSelId lbl ->
	let n = fieldLabelName lbl
        in
	case (moduleNamePair n) of { (mod, name) ->
	if isPreludeDefinedName n then [name] else [mod, name] }
1025

1026
1027
1028
      ImportedId n -> get_fullname_pieces n
      PreludeId  n -> get_fullname_pieces n
      TopLevId   n -> get_fullname_pieces n
1029
1030

      SuperDictSelId c sc ->
1031
1032
	case (moduleNamePair c)	of { (c_mod, c_name) ->
	case (moduleNamePair sc)	of { (sc_mod, sc_name) ->
1033
	let
1034
	    c_bits = if isPreludeDefined c
1035
1036
1037
		     then [c_name]
		     else [c_mod, c_name]

1038
	    sc_bits= if isPreludeDefined sc
1039
1040
1041
1042
1043
		     then [sc_name]
		     else [sc_mod, sc_name]
	in
	[SLIT("sdsel")] ++ c_bits ++ sc_bits  }}

1044
      MethodSelId clas op ->
1045
	case (moduleNamePair clas)	of { (c_mod, c_name) ->
1046
	case (classOpString op)	of { op_name ->
1047
1048
1049
	if isPreludeDefined clas
	then [op_name]
        else [c_mod, c_name, op_name]
1050
1051
1052
	} }

      DefaultMethodId clas op _ ->
1053
	case (moduleNamePair clas)		of { (c_mod, c_name) ->
1054
	case (classOpString op)	of { op_name ->
1055
	if isPreludeDefined clas
1056
1057
1058
	then [SLIT("defm"), op_name]
	else [SLIT("defm"), c_mod, c_name, op_name] }}

1059
      DictFunId c ty _ _ ->
1060
	case (moduleNamePair c)	    of { (c_mod, c_name) ->
1061
	let
1062
	    c_bits = if isPreludeDefined c
1063
1064
		     then [c_name]
		     else [c_mod, c_name]
1065

1066
1067
1068
1069
	    ty_bits = getTypeString ty
	in
	[SLIT("dfun")] ++ c_bits ++ ty_bits }

1070
      ConstMethodId c ty o _ _ ->
1071
	case (moduleNamePair c)	    of { (c_mod, c_name) ->
1072
	case (getTypeString ty)	    of { ty_bits ->
1073
	case (classOpString o)   of { o_name ->
1074
1075
1076
	case (if isPreludeDefined c
	      then [c_name]
	      else [c_mod, c_name]) of { c_bits ->
1077
1078
1079
1080
1081
1082
1083
	[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 _ ->
1084
1085
1086
	get unspec ++ (if not (toplevelishId unspec)
		       then [showUnique u]
		       else concat (map typeMaybeString ty_maybes))
1087
1088

      WorkerId unwrkr ->
1089
1090
1091
	get unwrkr ++ (if not (toplevelishId unwrkr)
		       then [showUnique u]
		       else [SLIT("wrk")])
1092
1093

      LocalId      n _   -> let local = getLocalName n in
1094
			    if show_uniqs then [local, showUnique u] else [local]
1095
      InstId       n _   -> [getLocalName n, showUnique u]
1096
1097
1098
      SysLocalId   n _   -> [getLocalName n, showUnique u]
      SpecPragmaId n _ _ -> [getLocalName n, showUnique u]

1099
get_fullname_pieces :: Name -> [FAST_STRING]
1100
get_fullname_pieces n
1101
  = BIND (moduleNamePair n) _TO_ (mod, name) ->
1102
    if isPreludeDefinedName n
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
    then [name]
    else [mod, name]
    BEND
\end{code}

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

\begin{code}
1115
1116
1117
idType :: GenId ty -> ty

idType (Id _ ty _ _ _) = ty
1118
1119
1120
\end{code}

\begin{code}
1121
{-LATER:
1122
1123
1124
getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)

getMentionedTyConsAndClassesFromId id
1125
1126
 = getMentionedTyConsAndClassesFromType (idType id)
-}
1127
1128
1129
\end{code}

\begin{code}
1130
idPrimRep i = typePrimRep (idType i)
1131
1132
\end{code}

1133
\begin{code}
1134
{-LATER:
1135
1136
1137
getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
getInstIdModule other = panic "Id:getInstIdModule"
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
-}
\end{code}

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

\begin{code}
1148
mkSuperDictSelId  u c sc     ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1149
mkMethodSelId     u c op     ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1150
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1151

1152
1153
mkDictFunId u c ity full_ty from_here mod info
  = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1154

1155
1156
mkConstMethodId	u c op ity full_ty from_here mod info
  = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1157

1158
mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1159

1160
mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170

{-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
1171
1172
      Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
	ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1173
1174
1175
1176
	       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."
1177
	])
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
-}
\end{code}

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

\begin{code}
1188
1189
mkImported  n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId  n) NoPragmaInfo info
1190

1191
1192
{-LATER:
updateIdType :: Id -> Type -> Id
1193
updateIdType (Id u _ info details) ty = Id u ty info details
1194
-}
1195
1196
1197
\end{code}

\begin{code}
1198
1199
1200
1201
type MyTy a b = GenType (GenTyVar a) b
type MyId a b = GenId (MyTy a b)

no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1202
1203
1204

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

mkSysLocal str uniq ty loc
1208
  = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1209
1210

mkUserLocal str uniq ty loc
1211
  = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1212
1213

-- mkUserId builds a local or top-level Id, depending on the name given
1214
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1215
1216
1217
1218
1219
1220
1221
mkUserId name ty pragma_info
  | isLocalName name
  = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
  | otherwise
  = Id (nameUnique name) ty 
       (if isLocallyDefinedName name then TopLevId name else ImportedId name)
        pragma_info noIdInfo
1222
1223
1224
1225
1226
\end{code}


\begin{code}
{-LATER:
1227

1228
-- for a SpecPragmaId being created by the compiler out of thin air...
1229
1230
1231
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))
1232

1233
-- for new SpecId
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
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
1252
    name = getOccName id
1253
    loc  = getSrcLoc id
1254
-}
1255
1256
1257

mkIdWithNewUniq :: Id -> Unique -> Id

1258
1259
mkIdWithNewUniq (Id _ ty details prag info) uniq
  = Id uniq ty details prag info
1260
1261
1262
1263
1264
1265
\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}
1266
mkTemplateLocals :: [Type] -> [Id]
1267
mkTemplateLocals tys
1268
  = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1269
1270
1271
1272
1273
	    (getBuiltinUniques (length tys))
	    tys
\end{code}

\begin{code}
1274
1275
getIdInfo     :: GenId ty -> IdInfo
getPragmaInfo :: GenId ty -> PragmaInfo
1276

1277
1278
getIdInfo     (Id _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ info _) = info
1279

1280
{-LATER:
1281
1282
1283
1284
replaceIdInfo :: Id -> IdInfo -> Id

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

1285
1286
1287
1288
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
  = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
    noIdInfo `addInfo_UF` getIdUnfolding unspec
1289
-}
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
\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}
1303
1304
getIdArity :: Id -> ArityInfo
getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
1305

1306
1307
dataConArity :: DataCon -> Int
dataConArity id@(Id _ _ _ _ id_info)
1308
1309
  = ASSERT(isDataCon id)
    case (arityMaybe (getInfo id_info)) of
1310
      Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1311
1312
1313
      Just  i -> i

addIdArity :: Id -> Int -> Id
1314
1315
addIdArity (Id u ty details pinfo info) arity
  = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1316
1317
1318
1319
1320
1321
1322
1323
1324
\end{code}

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

\begin{code}
1325
mkDataCon :: Name
1326
	  -> [StrictnessMark] -> [FieldLabel]
1327
1328
1329
1330
1331
	  -> [TyVar] -> ThetaType -> [TauType] -> TyCon
--ToDo:   -> SpecEnv
	  -> Id
  -- can get the tag and all the pieces of the type from the Type

1332
mkDataCon n stricts fields tvs ctxt args_tys tycon
1333
1334
  = ASSERT(length stricts == length args_tys)
    data_con
1335
  where
1336
1337
1338
    -- NB: data_con self-recursion; should be OK as tags are not
    -- looked at until late in the game.
    data_con
1339
      = Id (nameUnique n)
1340
	   type_of_constructor
1341
	   (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1342
1343
	   NoPragmaInfo
	   datacon_info
1344

1345
    data_con_tag    = position_within fIRST_TAG data_con_family
1346

1347
    data_con_family = tyConDataCons tycon
1348

1349
    position_within :: Int -> [Id] -> Int
1350

1351
1352
1353
1354
1355
1356
    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
1357

1358
1359
    type_of_constructor
      = mkSigmaTy tvs ctxt
1360
	(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1361
1362
1363

    datacon_info = noIdInfo `addInfo_UF` unfolding
			    `addInfo` mkArityInfo arity
1364
--ToDo: 		    `addInfo` specenv
1365
1366
1367
1368

    arity = length args_tys

    unfolding
1369
1370
      = noInfo_UF
{- LATER:
1371
1372
1373
1374
      = -- if arity == 0
    	-- then noIdInfo
	-- else -- do some business...
	let
1375
	    (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1376
	    tyvar_tys = mkTyVarTys tyvars
1377
	in
1378
	BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1379
1380

	mkUnfolding EssentialUnfolding -- for data constructors
1381
1382
		    (mkLam tyvars (dict_vars ++ vars) plain_Con)
	BEND
1383

1384
    mk_uf_bits tvs ctxt arg_tys tycon
1385
1386
      = let
	    (inst_env, tyvars, tyvar_tys)
1387
	      = instantiateTyVarTemplates tvs
1388
					  (map uniqueOf tvs)
1389
1390
1391
1392
	in
	    -- the "context" and "arg_tys" have TyVarTemplates in them, so
	    -- we instantiate those types to have the right TyVars in them
	    -- instead.
1393
	BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1394
1395
1396
1397
1398
1399
1400
1401
						       	_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 ->

1402
	BIND (splitAt (length ctxt) all_vars)	_TO_ (dict_vars, vars) ->
1403
1404
1405
1406

	(tyvars, dict_vars, vars)
	BEND BEND BEND BEND
      where
1407
	-- these are really dubious Types, but they are only to make the
1408
1409
	-- binders for the lambdas for tossed-away dicts.
	ctxt_ty (clas, ty) = mkDictTy clas ty
1410
-}
1411
1412
1413
1414
1415
\end{code}

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

1416
mkTupleCon arity
1417
  = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info 
1418
  where
1419
1420
    n		= mkTupleDataConName arity
    unique      = uniqueOf n
1421
1422
    ty 		= mkSigmaTy tyvars []
		   (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1423
1424
    tycon	= mkTupleTyCon arity
    tyvars	= take arity alphaTyVars
1425
    tyvar_tys	= mkTyVarTys tyvars
1426
1427
1428
1429

    tuplecon_info
      = noIdInfo `addInfo_UF` unfolding
		 `addInfo` mkArityInfo arity
1430
--LATER:?	 `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1431
1432

    unfolding
1433
1434
      = noInfo_UF
{- LATER:
1435
1436
1437
1438
1439
      = -- if arity == 0
    	-- then noIdInfo
	-- else -- do some business...
	let
	    (tyvars, dict_vars, vars) = mk_uf_bits arity
1440
	    tyvar_tys = mkTyVarTys tyvars
1441
	in
1442
	BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1443
1444
1445

	mkUnfolding
	    EssentialUnfolding    -- data constructors
1446
1447
	    (mkLam tyvars (dict_vars ++ vars) plain_Con)
	BEND
1448
1449
1450
1451
1452
1453
1454

    mk_uf_bits arity
      = BIND (mkTemplateLocals tyvar_tys)		 _TO_ vars ->
	(tyvars, [], vars)
	BEND
      where
	tyvar_tmpls	= take arity alphaTyVars