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