ClosureInfo.lhs 42.5 KB
Newer Older
1

2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
%
\section[ClosureInfo]{Data structures which describe closures}

Much of the rationale for these things is in the ``details'' part of
the STG paper.

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

module ClosureInfo (
	ClosureInfo, LambdaFormInfo, SMRep, 	-- all abstract
	StandardFormInfo,

	EntryConvention(..),

	mkClosureLFInfo, mkConLFInfo,
	mkLFImported, mkLFArgument, mkLFLetNoEscape,

	closureSize, closureHdrSize,
	closureNonHdrSize, closureSizeWithoutFixedHdr,
23
	closureGoodStuffSize, closurePtrsSize,
24
25
26
27
	slopSize, fitsMinUpdSize,

	layOutDynClosure, layOutDynCon, layOutStaticClosure,
	layOutStaticNoFVClosure, layOutPhantomClosure,
28
	mkVirtHeapOffsets, -- for GHCI
29
30
31
32

	nodeMustPointToIt, getEntryConvention,
	blackHoleOnEntry,

33
	staticClosureRequired,
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
	slowFunEntryCodeRequired, funInfoTableRequired,
	stdVapRequired, noUpdVapRequired,

	closureId, infoTableLabelFromCI,
	closureLabelFromCI,
	entryLabelFromCI, fastLabelFromCI,
	closureLFInfo, closureSMRep, closureUpdReqd,
	closureSingleEntry, closureSemiTag, closureType,
	closureReturnsUnboxedType, getStandardFormThunkInfo,

	closureKind, closureTypeDescr,		-- profiling

	isStaticClosure, allocProfilingMsg,
	blackHoleClosureInfo,
	maybeSelectorInfo,

50
    	dataConLiveness				-- concurrency
51
52
    ) where

53
54
55
import Ubiq{-uitous-}
import AbsCLoop		-- here for paranoia-checking

56
57
import AbsCSyn
import StgSyn
58
import CgMonad
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
import CgCompInfo	( mAX_SPEC_SELECTEE_SIZE,
			  mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
			  mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
			  mAX_SPEC_ALL_NONPTRS,
			  oTHER_TAG
			)
import CgRetConv	( assignRegs, dataReturnConvAlg,
			  DataReturnConvention(..)
			)
import CLabel		( mkStdEntryLabel, mkFastEntryLabel,
			  mkPhantomInfoTableLabel, mkInfoTableLabel,
			  mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
			  mkStaticInfoTableLabel, mkStaticConEntryLabel,
			  mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
			)
import CmdLineOpts	( opt_SccProfilingOn, opt_ForConcurrent )
import HeapOffs		( intOff, addOff, totHdrSize, varHdrSize,
			  intOffsetIntoGoods,
			  VirtualHeapOffset(..)
			)
import Id		( idType, idPrimRep, getIdArity,
			  externallyVisibleId, dataConSig,
			  dataConTag, fIRST_TAG,
			  isDataCon, dataConArity, dataConTyCon,
			  isTupleCon, DataCon(..),
			  GenId{-instance Eq-}
			)
import IdInfo		( arityMaybe )
import Maybes		( assocMaybe, maybeToBool )
89
import Name		( isLocallyDefined, getLocalName )
90
91
92
93
94
import PprStyle		( PprStyle(..) )
import PprType		( GenType{-instance Outputable-} )
import PrimRep		( getPrimRepSize, separateByPtrFollowness )
import SMRep		-- all of it
import TyCon		( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
95
import Type		( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys )
96
97
98
99
100
101
import Util		( isIn, mapAccumL, panic, pprPanic, assertPanic )

maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)"
getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)"
getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
\end{code}

The ``wrapper'' data type for closure information:

\begin{code}
data ClosureInfo
  = MkClosureInfo
	Id			-- The thing bound to this closure
	LambdaFormInfo		-- info derivable from the *source*
	SMRep			-- representation used by storage manager
\end{code}

%************************************************************************
%*									*
\subsection[ClosureInfo-OLD-DOC]{OLD DOCUMENTATION PROBABLY SUPERCEDED BY stg-details}
%*									*
%************************************************************************

We can optimise the function-entry code as follows.
\begin{itemize}

\item	If the ``function'' is not updatable, we can jump directly to its
	entry code, rather than indirecting via the info pointer in the
	closure.  (For updatable thunks we must go via the closure, in
	case it has been updated.)

\item	If the former bullet applies, and the application we are
	compiling gives the function as many arguments as it needs, we
	can jump to its fast-entry code.  (This only applies if the
	function has one or more args, because zero-arg closures have
	no fast-entry code.)

\item	If the function is a top-level non-constructor or imported, there
	is no need to make Node point to its closure.  In order for
	this to be right, we need to ensure that:
	\begin{itemize}
	\item	If such closures are updatable then they push their
		static address in the update frame, not Node. Actually
		we create a black hole and push its address.

	\item	The arg satisfaction check should load Node before jumping to
		UpdatePAP.

	\item 	Top-level constructor closures need careful handling.  If we are to
		jump direct to the constructor code, we must load Node first, even
		though they are top-level.  But if we go to their ``own''
		standard-entry code (which loads Node and then jumps to the
		constructor code) we don't need to load Node.
	\end{itemize}
\end{itemize}


{\em Top level constructors (@mkStaticConEntryInfo@)}

\begin{verbatim}
	x = {y,ys} \ {} Cons {y,ys}	-- Std form constructor
\end{verbatim}

x-closure: Cons-info-table, y-closure, ys-closure

x-entry: Node = x-closure; jump( Cons-entry )

x's EntryInfo in its own module:
\begin{verbatim}
		Base-label = Cons		-- Not x!!
		NodeMustPoint = True
		ClosureClass = Constructor
\end{verbatim}

	So if x is entered, Node will be set up and
	we'll jump direct to the Cons code.

x's EntryInfo in another module: (which may not know that x is a constructor)
\begin{verbatim}
		Base-label = x			-- Is x!!
		NodeMustPoint = False		-- All imported things have False
		ClosureClass = non-committal
\end{verbatim}

	If x is entered, we'll jump to x-entry, which will set up Node
	before jumping to the standard Cons code

{\em Top level non-constructors (@mkStaticEntryInfo@)}
\begin{verbatim}
	x = ...
\end{verbatim}

For updatable thunks, x-entry must push an allocated BH in update frame, not Node.

For non-zero arity, arg satis check must load Node before jumping to
	UpdatePAP.

x's EntryInfo in its own module:
\begin{verbatim}
		Base-label = x
		NodeMustPoint = False
		ClosureClass = whatever
\end{verbatim}

{\em Inner constructors (@mkConEntryInfo@)}

\begin{verbatim}
		Base-label = Cons		-- Not x!!
		NodeMustPoint = True		-- If its arity were zero, it would
						-- have been lifted to top level
		ClosureClass = Constructor
\end{verbatim}

{\em Inner non-constructors (@mkEntryInfo@)}

\begin{verbatim}
		Base-label = x
		NodeMustPoint = True		-- If no free vars, would have been
						-- lifted to top level
		ClosureClass = whatever
\end{verbatim}

{\em Imported}

\begin{verbatim}
		Nothing,
	or
		Base-label = x
		NodeMustPoint = False
		ClosureClass = whatever
\end{verbatim}

==============
THINK: we could omit making Node point to top-level constructors
of arity zero; but that might interact nastily with updates.
==============


==========
The info we need to import for imported things is:

\begin{verbatim}
	data ImportInfo = UnknownImportInfo
			| HnfImport Int		-- Not updatable, arity given
						-- Arity can be zero, for (eg) constrs
			| UpdatableImport	-- Must enter via the closure
\end{verbatim}

ToDo: move this stuff???

\begin{pseudocode}
mkStaticEntryInfo lbl cl_class
  = MkEntryInfo lbl False cl_class

mkStaticConEntryInfo lbl
  = MkEntryInfo lbl True ConstructorClosure

mkEntryInfo lbl cl_class
  = MkEntryInfo lbl True cl_class

mkConEntryInfo lbl
  = MkEntryInfo lbl True ConstructorClosure
\end{pseudocode}

%************************************************************************
%*									*
\subsection[ClosureInfo-datatypes]{Data types for closure information}
%*									*
%************************************************************************

%************************************************************************
%*									*
\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
%*									*
%************************************************************************

\begin{code}
data LambdaFormInfo
  = LFReEntrant		-- Reentrant closure; used for PAPs too
	Bool		-- True if top level
	Int		-- Arity
	Bool		-- True <=> no fvs

  | LFCon		-- Constructor
	DataCon		-- The constructor (may be specialised)
	Bool		-- True <=> zero arity

  | LFTuple		-- Tuples
	DataCon		-- The tuple constructor (may be specialised)
	Bool		-- True <=> zero arity
287

288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
  | LFThunk		-- Thunk (zero arity)
	Bool		-- True <=> top level
	Bool		-- True <=> no free vars
	Bool		-- True <=> updatable (i.e., *not* single-entry)
	StandardFormInfo

  | LFArgument		-- Used for function arguments.  We know nothing about
			-- this closure.  Treat like updatable "LFThunk"...

  | LFImported		-- Used for imported things.  We know nothing about this
			-- closure.  Treat like updatable "LFThunk"...
			-- Imported things which we do know something about use
			-- one of the other LF constructors (eg LFReEntrant for
			-- known functions)

  | LFLetNoEscape	-- See LetNoEscape module for precise description of
			-- these "lets".
	Int		-- arity;
306
	StgLiveVars-- list of variables live in the RHS of the let.
307
308
309
310
311
312
313
314
			-- (ToDo: maybe not used)

  | LFBlackHole		-- Used for the closures allocated to hold the result
			-- of a CAF.  We want the target of the update frame to
			-- be in the heap, so we make a black hole to hold it.

  -- This last one is really only for completeness;
  -- it isn't actually used for anything interesting
315
  {- | LFIndirection -}
316
317
318
319
320
321

data StandardFormInfo	-- Tells whether this thunk has one of a small number
			-- of standard forms

  = NonStandardThunk	-- No, it isn't

322
 | SelectorThunk
323
324
325
326
327
       Id              	-- Scrutinee
       DataCon         	-- Constructor
       Int             	-- 0-origin offset of ak within the "goods" of constructor
			-- (Recall that the a1,...,an may be laid out in the heap
			--  in a non-obvious order.)
328

329
330
{- A SelectorThunk is of form

331
332
333
334
     case x of
       con a1,..,an -> ak

   and the constructor is from a single-constr type.
335
336
337
   If we can't convert the heap-offset of the selectee into an Int, e.g.,
   it's "GEN_VHS+i", we just give up.
-}
338

339
340
  | VapThunk
	Id			-- Function
341
342
	[StgArg]		-- Args
	Bool			-- True <=> the function is not top-level, so
343
				-- must be stored in the thunk too
344

345
346
{- A VapThunk is of form

347
	f a1 ... an
348

349
350
351
352
353
   where f is a known function, with arity n
   So for this thunk we can use the label for f's heap-entry
   info table (generated when f's defn was dealt with),
   rather than generating a one-off info table and entry code
   for this one thunk.
354
355
-}

356

357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
mkLFArgument	= LFArgument
mkLFBlackHole	= LFBlackHole
mkLFLetNoEscape = LFLetNoEscape

mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
  = case arityMaybe (getIdArity id) of
      Nothing  	-> LFImported
      Just 0	-> LFThunk True{-top-lev-} True{-no fvs-}
			True{-updatable-} NonStandardThunk
      Just n	-> LFReEntrant True n True  -- n > 0
\end{code}

%************************************************************************
%*									*
\subsection[ClosureInfo-construction]{Functions which build LFInfos}
%*									*
%************************************************************************

@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.

\begin{code}
mkClosureLFInfo :: Bool 	-- True of top level
		-> [Id]		-- Free vars
		-> UpdateFlag 	-- Update flag
		-> [Id] 	-- Args
383
		-> StgExpr	-- Body of closure: passed so we
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
				-- can look for selector thunks!
		-> LambdaFormInfo

mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args
  = LFReEntrant top (length args) (null fvs)

mkClosureLFInfo top fvs ReEntrant [] body
  = LFReEntrant top 0 (null fvs)
\end{code}

OK, this is where we look at the body of the closure to see if it's a
selector---turgid, but nothing deep.  We are looking for a closure of
{\em exactly} the form:
\begin{verbatim}
...  = [the_fv] \ u [] ->
	 case the_fv of
	   con a_1 ... a_n -> a_i
\end{verbatim}
Here we go:
\begin{code}
mkClosureLFInfo False	    -- don't bother if at top-level
		[the_fv]    -- just one...
		Updatable
		[]	    -- no args (a thunk)
408
		(StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
409
410
411
		  _ _ _   -- ignore live vars and uniq...
		  (StgAlgAlts case_ty
		     [(con, params, use_mask,
412
			(StgApp (StgVarArg selectee) [{-no args-}] _))]
413
414
415
416
417
		     StgNoDefault))
  |  the_fv == scrutinee			-- Scrutinee is the only free variable
  && maybeToBool maybe_offset			-- Selectee is a component of the tuple
  && maybeToBool offset_into_int_maybe
  && offset_into_int <= mAX_SPEC_SELECTEE_SIZE	-- Offset is small enough
418
  =
419
    -- ASSERT(is_single_constructor) 		-- Should be true, by causes error for SpecTyCon
420
421
    LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
  where
422
    (_, params_w_offsets) = layOutDynCon con idPrimRep params
423
424
    maybe_offset	  = assocMaybe params_w_offsets selectee
    Just the_offset 	  = maybe_offset
425
    offset_into_int_maybe = intOffsetIntoGoods the_offset
426
    Just offset_into_int  = offset_into_int_maybe
427
428
    is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
    (_,_,_, tycon)	  = dataConSig con
429
430
431
432
433
434
435
436
437
438
439
440
441
\end{code}

Same kind of thing, looking for vector-apply thunks, of the form:

	x = [...] \ .. [] -> f a1 .. an

where f has arity n.  We rely on the arity info inside the Id being correct.

\begin{code}
mkClosureLFInfo top_level
		fvs
		upd_flag
		[]			-- No args; a thunk
442
443
		(StgApp (StgVarArg fun_id) args _)
  | not top_level			-- A top-level thunk would require a static
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
					-- vap_info table, which we don't generate just
					-- now; so top-level thunks are never standard
					-- form.
  && isLocallyDefined fun_id		-- Must be defined in this module
  && maybeToBool arity_maybe		-- A known function with known arity
  && fun_arity > 0			-- It'd better be a function!
  && fun_arity == length args		-- Saturated application
  = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap)
  where
    arity_maybe      = arityMaybe (getIdArity fun_id)
    Just fun_arity   = arity_maybe

	-- If the function is a free variable then it must be stored
	-- in the thunk too; if it isn't a free variable it must be
	-- because it's constant, so it doesn't need to be stored in the thunk
    store_fun_in_vap = fun_id `is_elem` fvs

    is_elem = isIn "mkClosureLFInfo"
\end{code}

Finally, the general updatable-thing case:
\begin{code}
mkClosureLFInfo top fvs upd_flag [] body
  = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk

isUpdatable ReEntrant   = False
isUpdatable SingleEntry = False
isUpdatable Updatable   = True
\end{code}

@mkConLFInfo@ is similar, for constructors.

\begin{code}
mkConLFInfo :: DataCon -> LambdaFormInfo

mkConLFInfo con
  = ASSERT(isDataCon con)
    let
482
	arity = dataConArity con
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
    in
    if isTupleCon con then
	LFTuple con (arity == 0)
    else
	LFCon con (arity == 0)
\end{code}


%************************************************************************
%*									*
\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
%*									*
%************************************************************************

\begin{code}
closureSize :: ClosureInfo -> HeapOffset
closureSize cl_info@(MkClosureInfo _ _ sm_rep)
  = totHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))

closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
closureSizeWithoutFixedHdr cl_info@(MkClosureInfo _ _ sm_rep)
  = varHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))

closureHdrSize :: ClosureInfo -> HeapOffset
closureHdrSize (MkClosureInfo _ _ sm_rep)
  = totHdrSize sm_rep

closureNonHdrSize :: ClosureInfo -> Int
closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
  = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) --ToDo: pass lf_info?
  where
    tot_wds = closureGoodStuffSize cl_info

closureGoodStuffSize :: ClosureInfo -> Int
closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
  = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
    in	ptrs + nonptrs

closurePtrsSize :: ClosureInfo -> Int
closurePtrsSize (MkClosureInfo _ _ sm_rep)
  = let (ptrs, _) = sizes_from_SMRep sm_rep
    in	ptrs

-- not exported:
sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _)   = (ptrs, nonptrs)
sizes_from_SMRep (GenericRep       ptrs nonptrs _)   = (ptrs, nonptrs)
sizes_from_SMRep (BigTupleRep      ptrs)	     = (ptrs, 0)
sizes_from_SMRep (MuTupleRep       ptrs)	     = (ptrs, 0)
sizes_from_SMRep (DataRep               nonptrs)     = (0, nonptrs)
sizes_from_SMRep BlackHoleRep			     = (0, 0)
sizes_from_SMRep (StaticRep        ptrs nonptrs)     = (ptrs, nonptrs)
#ifdef DEBUG
sizes_from_SMRep PhantomRep	  = panic "sizes_from_SMRep: PhantomRep"
sizes_from_SMRep DynamicRep	  = panic "sizes_from_SMRep: DynamicRep"
#endif
\end{code}

\begin{code}
fitsMinUpdSize :: ClosureInfo -> Bool
fitsMinUpdSize (MkClosureInfo _ _ BlackHoleRep) = True
fitsMinUpdSize cl_info = isSpecRep (closureSMRep cl_info) && closureNonHdrSize cl_info <= mIN_UPD_SIZE
\end{code}

Computing slop size.  WARNING: this looks dodgy --- it has deep
knowledge of what the storage manager does with the various
representations...

Slop Requirements:
\begin{itemize}
\item
Updateable closures must be @mIN_UPD_SIZE@.
	\begin{itemize}
	\item
	Cons cell requires 2 words
	\item
	Indirections require 1 word
	\item
	Appels collector indirections 2 words
	\end{itemize}
THEREFORE: @mIN_UPD_SIZE = 2@.

\item
Collectable closures which are allocated in the heap
must be	@mIN_SIZE_NonUpdHeapObject@.

Copying collector forward pointer requires 1 word

THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@

\item
@SpecialisedRep@ closures closures may require slop:
	\begin{itemize}
	\item
	@ConstantRep@ and @CharLikeRep@ closures always use the address of
	a static closure. They are never allocated or
	collected (eg hold forwarding pointer) hence never any slop.
579

580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
	\item
	@IntLikeRep@ are never updatable.
	May need slop to be collected (as they will be size 1 or more
	this probably has no affect)

	\item
	@SpecRep@ may be updateable and will be collectable

	\item
	@StaticRep@ may require slop if updatable. Non-updatable ones are OK.

	\item
	@GenericRep@ closures will always be larger so never require slop.
	\end{itemize}

	***** ToDo: keep an eye on this!
\end{itemize}

\begin{code}
slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
  = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info)

computeSlopSize :: Int -> SMRep -> Bool -> Int

computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _
  = 0
computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _
  = 0

computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True	-- Updatable
  = max 0 (mIN_UPD_SIZE - tot_wds)
computeSlopSize tot_wds (StaticRep _ _) True		-- Updatable
  = max 0 (mIN_UPD_SIZE - tot_wds)
computeSlopSize tot_wds BlackHoleRep _			-- Updatable
  = max 0 (mIN_UPD_SIZE - tot_wds)

computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False	-- Not updatable
  = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)

computeSlopSize tot_wds other_rep _			-- Any other rep
  = 0
\end{code}

%************************************************************************
%*									*
\subsection[layOutDynClosure]{Lay out a dynamic closure}
%*									*
%************************************************************************

\begin{code}
layOutDynClosure, layOutStaticClosure
	:: Id			    -- STG identifier w/ which this closure assoc'd
632
	-> (a -> PrimRep)    	    -- function w/ which to be able to get a PrimRep
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
	-> [a]			    -- the "things" being layed out
	-> LambdaFormInfo	    -- what sort of closure it is
	-> (ClosureInfo,	    -- info about the closure
	    [(a, VirtualHeapOffset)])	-- things w/ offsets pinned on them

layOutDynClosure name kind_fn things lf_info
  = (MkClosureInfo name lf_info sm_rep,
     things_w_offsets)
  where
    (tot_wds,		 -- #ptr_wds + #nonptr_wds
     ptr_wds,		 -- #ptr_wds
     things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things
    sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds

layOutStaticClosure name kind_fn things lf_info
  = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)),
     things_w_offsets)
  where
    (tot_wds,		 -- #ptr_wds + #nonptr_wds
     ptr_wds,		 -- #ptr_wds
     things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot) kind_fn things
    bot = panic "layoutStaticClosure"

layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
layOutStaticNoFVClosure name lf_info
  = MkClosureInfo name lf_info (StaticRep ptr_wds nonptr_wds)
 where
  -- I am very uncertain that this is right - it will show up when testing
  -- my dynamic loading code.  ADR
  -- (If it's not right, we'll have to grab the kinds of the arguments from
  --  somewhere.)
  ptr_wds = 0
  nonptr_wds = 0

layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep
\end{code}

A wrapper for when used with data constructors:
\begin{code}
layOutDynCon :: DataCon
674
	     -> (a -> PrimRep)
675
676
677
	     -> [a]
	     -> (ClosureInfo, [(a,VirtualHeapOffset)])

678
layOutDynCon con kind_fn args
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
  = ASSERT(isDataCon con)
    layOutDynClosure con kind_fn args (mkConLFInfo con)
\end{code}


%************************************************************************
%*									*
\subsection[SMreps]{Choosing SM reps}
%*									*
%************************************************************************

\begin{code}
chooseDynSMRep
	:: LambdaFormInfo
	-> Int -> Int		-- Tot wds, ptr wds
	-> SMRep

chooseDynSMRep lf_info tot_wds ptr_wds
  = let
	 nonptr_wds = tot_wds - ptr_wds

	 updatekind = case lf_info of
	     LFThunk _ _ upd _  -> if upd then SMUpdatable else SMSingleEntry
	     LFBlackHole	-> SMUpdatable
	     _  	    	-> SMNormalForm
    in
    if (nonptr_wds == 0 && ptr_wds <= mAX_SPEC_ALL_PTRS)
	    || (tot_wds <= mAX_SPEC_MIXED_FIELDS)
	    || (ptr_wds == 0 && nonptr_wds <= mAX_SPEC_ALL_NONPTRS) then
	let
	  spec_kind  = case lf_info of

	   (LFTuple _ True) -> ConstantRep

	   (LFTuple _ _)  -> SpecRep

	   (LFCon _ True) -> ConstantRep

	   (LFCon con _ ) -> if maybeToBool (maybeCharLikeTyCon tycon) then CharLikeRep
			     else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
			     else SpecRep
			     where
721
			     tycon = dataConTyCon con
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741

	   _ 		  -> SpecRep
	in
	SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind
    else
	GenericRep ptr_wds nonptr_wds updatekind
\end{code}


%************************************************************************
%*									*
\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
%*									*
%************************************************************************

@mkVirtHeapOffsets@ (the heap version) always returns boxed things with
smaller offsets than the unboxed things, and furthermore, the offsets in
the result list

\begin{code}
742
mkVirtHeapOffsets :: SMRep	-- Representation to be used by storage manager
743
	  -> (a -> PrimRep)	-- To be able to grab kinds;
744
745
746
747
748
749
750
				--  	w/ a kind, we can find boxedness
	  -> [a]		-- Things to make offsets for
	  -> (Int,		-- *Total* number of words allocated
	      Int,		-- Number of words allocated for *pointers*
	      [(a, VirtualHeapOffset)])
				-- Things with their offsets from start of object
				-- 	in order of increasing offset
751
752
753
754
755
756
757
758
759
760
761
762

-- First in list gets lowest offset, which is initial offset + 1.

mkVirtHeapOffsets sm_rep kind_fun things
  = let (ptrs, non_ptrs)    	      = separateByPtrFollowness kind_fun things
    	(wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
	(tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
    in
	(tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
  where
    offset_of_first_word = totHdrSize sm_rep
    computeOffset wds_so_far thing
763
      = (wds_so_far + (getPrimRepSize . kind_fun) thing,
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
	 (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
	)
\end{code}

%************************************************************************
%*									*
\subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
%*									*
%************************************************************************

Be sure to see the stg-details notes about these...

\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
779
780
781
  = let
	do_profiling = opt_SccProfilingOn
    in
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
    case lf_info of
	LFReEntrant top arity no_fvs -> returnFC (
	    not no_fvs ||   -- Certainly if it has fvs we need to point to it

	    not top -- If it is not top level we will point to it
		    --   We can have a \r closure with no_fvs which
		    --   is not top level as special case cgRhsClosure
		    --   has been dissabled in favour of let floating

		-- For lex_profiling we also access the cost centre for a
		-- non-inherited function i.e. not top level
		-- the  not top  case above ensures this is ok.
	    )

	LFCon	_ zero_arity -> returnFC True
	LFTuple _ zero_arity -> returnFC True

	-- Strictly speaking, the above two don't need Node to point
	-- to it if the arity = 0.  But this is a *really* unlikely
	-- situation.  If we know it's nil (say) and we are entering
	-- it. Eg: let x = [] in x then we will certainly have inlined
	-- x, since nil is a simple atom.  So we gain little by not
	-- having Node point to known zero-arity things.  On the other
	-- hand, we do lose something; Patrick's code for figuring out
	-- when something has been updated but not entered relies on
	-- having Node point to the result of an update.  SLPJ
	-- 27/11/92.

	LFThunk _ no_fvs updatable _
	  -> returnFC (updatable || not no_fvs || do_profiling)

	  -- For the non-updatable (single-entry case):
	  --
	  -- True if has fvs (in which case we need access to them, and we
	  --		    should black-hole it)
	  -- or profiling (in which case we need to recover the cost centre
	  --		 from inside it)

	LFArgument  -> returnFC True
	LFImported  -> returnFC True
	LFBlackHole -> returnFC True
		    -- BH entry may require Node to point

	LFLetNoEscape _ _ -> returnFC False
\end{code}

The entry conventions depend on the type of closure being entered,
whether or not it has free variables, and whether we're running
sequentially or in parallel.

\begin{tabular}{lllll}
Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\
Unknown 			& no & yes & stack	& node \\
Known fun ($\ge$ 1 arg), no fvs 	& no & no  & registers 	& fast entry (enough args) \\
\ & \ & \ & \ 						& slow entry (otherwise) \\
Known fun ($\ge$ 1 arg), fvs	& no & yes & registers 	& fast entry (enough args) \\
0 arg, no fvs @\r,\s@ 		& no & no  & n/a 	& direct entry \\
0 arg, no fvs @\u@ 		& no & yes & n/a 	& node \\
0 arg, fvs @\r,\s@ 		& no & yes & n/a 	& direct entry \\
0 arg, fvs @\u@ 		& no & yes & n/a 	& node \\

Unknown 			& yes & yes & stack	& node \\
Known fun ($\ge$ 1 arg), no fvs 	& yes & no  & registers & fast entry (enough args) \\
\ & \ & \ & \ 						& slow entry (otherwise) \\
Known fun ($\ge$ 1 arg), fvs	& yes & yes & registers & node \\
0 arg, no fvs @\r,\s@ 		& yes & no  & n/a 	& direct entry \\
0 arg, no fvs @\u@ 		& yes & yes & n/a 	& node \\
0 arg, fvs @\r,\s@ 		& yes & yes & n/a 	& node \\
0 arg, fvs @\u@ 		& yes & yes & n/a 	& node\\
\end{tabular}

853
When black-holing, single-entry closures could also be entered via node
854
855
856
857
858
859
860
(rather than directly) to catch double-entry.

\begin{code}
data EntryConvention
  = ViaNode				-- The "normal" convention

  | StdEntry CLabel			-- Jump to this code, with args on stack
861
	     (Maybe CLabel) 	    	-- possibly setting infoptr to this
862
863
864
865
866
867
868
869

  | DirectEntry 			-- Jump directly to code, with args in regs
	CLabel 				--   The code label
	Int 				--   Its arity
	[MagicId]			--   Its register assignments (possibly empty)

getEntryConvention :: Id			-- Function being applied
		   -> LambdaFormInfo		-- Its info
870
		   -> [PrimRep]		-- Available arguments
871
872
873
		   -> FCode EntryConvention

getEntryConvention id lf_info arg_kinds
874
 =  nodeMustPointToIt lf_info	`thenFC` \ node_points ->
875
876
877
    let
	is_concurrent = opt_ForConcurrent
    in
878
879
880
881
882
883
    returnFC (

    if (node_points && is_concurrent) then ViaNode else

    case lf_info of

884
885
	LFReEntrant _ arity _ ->
	    if arity == 0 || (length arg_kinds) < arity then
886
		StdEntry (mkStdEntryLabel id) Nothing
887
	    else
888
889
		DirectEntry (mkFastEntryLabel id arity) arity arg_regs
	  where
890
	    (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
891
892
    	    live_regs = if node_points then [node] else []

893
894
	LFCon con zero_arity
			  -> let itbl = if zero_arity then
895
896
897
898
899
    	    	    	    	        mkPhantomInfoTableLabel con
    	    	    	    	    	else
    	    	    	    	    	mkInfoTableLabel con
    	    	    	     in StdEntry (mkStdEntryLabel con) (Just itbl)
				-- Should have no args
900
	LFTuple tup zero_arity
901
902
903
904
905
906
907
908
909
			 -> StdEntry (mkStdEntryLabel tup)
				     (Just (mkInfoTableLabel tup))
				-- Should have no args

	LFThunk _ _ updatable std_form_info
	  -> if updatable
	     then ViaNode
	     else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing

910
911
912
	LFArgument  -> ViaNode
	LFImported  -> ViaNode
	LFBlackHole -> ViaNode	-- Presumably the black hole has by now
913
914
915
916
917
				-- been updated, but we don't know with
				-- what, so we enter via Node

	LFLetNoEscape arity _
	  -> ASSERT(arity == length arg_kinds)
918
	     DirectEntry (mkStdEntryLabel id) arity arg_regs
919
	 where
920
	    (arg_regs, _) = assignRegs live_regs arg_kinds
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
    	    live_regs     = if node_points then [node] else []
    )

blackHoleOnEntry :: Bool	-- No-black-holing flag
		 -> ClosureInfo
		 -> Bool

-- Static closures are never themselves black-holed.
-- Updatable ones will be overwritten with a CAFList cell, which points to a black hole;
-- Single-entry ones have no fvs to plug, and we trust they don't form part of a loop.

blackHoleOnEntry no_black_holing (MkClosureInfo _ _ (StaticRep _ _)) = False

blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
  = case lf_info of
	LFReEntrant _ _ _	  -> False
	LFThunk _ no_fvs updatable _
	  -> if updatable
	     then not no_black_holing
	     else not no_fvs
941
	other -> panic "blackHoleOnEntry"	-- Should never happen
942

943
944
945
getStandardFormThunkInfo
	:: LambdaFormInfo
	-> Maybe [StgArg]		-- Nothing    => not a standard-form thunk
946
947
948
949
950
					-- Just atoms => a standard-form thunk with payload atoms

getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
  = --trace "Selector thunk: missed opportunity to save info table + code"
    Nothing
951
	-- Just [StgVarArg scrutinee]
952
953
954
955
	-- We can't save the info tbl + code until we have a way to generate
	-- a fixed family thereof.

getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
956
  | fun_in_payload = Just (StgVarArg fun_id : args)
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
  | otherwise	   = Just args

getStandardFormThunkInfo other_lf_info = Nothing

maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset)
maybeSelectorInfo _ = Nothing
\end{code}

Avoiding generating entries and info tables
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At present, for every function we generate all of the following,
just in case.  But they aren't always all needed, as noted below:

[NB1: all of this applies only to *functions*.  Thunks always
have closure, info table, and entry code.]

[NB2: All are needed if the function is *exported*, just to play safe.]


* Fast-entry code  ALWAYS NEEDED

* Slow-entry code
	Needed iff (a) we have any un-saturated calls to the function
	OR	   (b) the function is passed as an arg
	OR	   (c) we're in the parallel world and the function has free vars
			[Reason: in parallel world, we always enter functions
			with free vars via the closure.]

* The function closure
	Needed iff (a) we have any un-saturated calls to the function
	OR	   (b) the function is passed as an arg
	OR	   (c) if the function has free vars (ie not top level)

990
  Why case (a) here?  Because if the arg-satis check fails,
991
992
993
994
  UpdatePAP stuffs a pointer to the function closure in the PAP.
  [Could be changed; UpdatePAP could stuff in a code ptr instead,
   but doesn't seem worth it.]

995
  [NB: these conditions imply that we might need the closure
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
  without the slow-entry code.  Here's how.

	f x y = let g w = ...x..y..w...
		in
		...(g t)...

  Here we need a closure for g which contains x and y,
  but since the calls are all saturated we just jump to the
  fast entry point for g, with R1 pointing to the closure for g.]


* Standard info table
	Needed iff (a) we have any un-saturated calls to the function
	OR	   (b) the function is passed as an arg
	OR 	   (c) the function has free vars (ie not top level)
1011

1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
	NB.  In the sequential world, (c) is only required so that the function closure has
	an info table to point to, to keep the storage manager happy.
	If (c) alone is true we could fake up an info table by choosing
	one of a standard family of info tables, whose entry code just
	bombs out.

	[NB In the parallel world (c) is needed regardless because
	we enter functions with free vars via the closure.]

	If (c) is retained, then we'll sometimes generate an info table
	(for storage mgr purposes) without slow-entry code.  Then we need
	to use an error label in the info table to substitute for the absent
	slow entry code.

* Standard vap-entry code
  Standard vap-entry info table
	Needed iff we have any updatable thunks of the standard vap-entry shape.

* Single-update vap-entry code
  Single-update vap-entry info table
1032
	Needed iff we have any non-updatable thunks of the
1033
	standard vap-entry shape.
1034

1035
1036
1037
1038

\begin{code}
staticClosureRequired
	:: Id
1039
	-> StgBinderInfo
1040
1041
	-> LambdaFormInfo
	-> Bool
1042
staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
		      (LFReEntrant top_level _ _)	-- It's a function
  = ASSERT( top_level )		 	-- Assumption: it's a top-level, no-free-var binding
    arg_occ 		-- There's an argument occurrence
    || unsat_occ	-- There's an unsaturated call
    || externallyVisibleId binder

staticClosureRequired binder other_binder_info other_lf_info = True

slowFunEntryCodeRequired	-- Assumption: it's a function, not a thunk.
	:: Id
	-> StgBinderInfo
	-> Bool
slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
  = arg_occ 		-- There's an argument occurrence
    || unsat_occ	-- There's an unsaturated call
    || externallyVisibleId binder
    {- HAS FREE VARS AND IS PARALLEL WORLD -}

slowFunEntryCodeRequired binder NoStgBinderInfo = True

funInfoTableRequired
	:: Id
	-> StgBinderInfo
	-> LambdaFormInfo
	-> Bool
funInfoTableRequired  binder (StgBinderInfo arg_occ unsat_occ _ _ _)
1069
		     (LFReEntrant top_level _ _)
1070
1071
1072
1073
1074
1075
1076
  = not top_level
    || arg_occ 		-- There's an argument occurrence
    || unsat_occ	-- There's an unsaturated call
    || externallyVisibleId binder

funInfoTableRequired other_binder_info binder other_lf_info = True

1077
1078
-- We need the vector-apply entry points for a function if
-- there's a vector-apply occurrence in this module
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129

stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool

stdVapRequired binder_info
  = case binder_info of
      StgBinderInfo _ _ std_vap_occ _ _ -> std_vap_occ
      _				        -> False

noUpdVapRequired binder_info
  = case binder_info of
      StgBinderInfo _ _ _ no_upd_vap_occ _ -> no_upd_vap_occ
      _					   -> False
\end{code}

%************************************************************************
%*									*
\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
%*									*
%************************************************************************

\begin{code}

isStaticClosure :: ClosureInfo -> Bool
isStaticClosure  (MkClosureInfo _ _ rep) = isStaticRep  rep

closureId :: ClosureInfo -> Id
closureId (MkClosureInfo id _ _) = id

closureSMRep :: ClosureInfo -> SMRep
closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep

closureLFInfo :: ClosureInfo -> LambdaFormInfo
closureLFInfo (MkClosureInfo _ lf_info _) = lf_info

closureUpdReqd :: ClosureInfo -> Bool

closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd
closureUpdReqd (MkClosureInfo _ LFBlackHole _)         = True
	-- Black-hole closures are allocated to receive the results of an
	-- alg case with a named default... so they need to be updated.
closureUpdReqd other_closure			       = False

closureSingleEntry :: ClosureInfo -> Bool

closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd
closureSingleEntry other_closure			   = False
\end{code}

Note: @closureType@ returns appropriately specialised tycon and
datacons.
\begin{code}
1130
closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
1131
1132
1133
1134
1135
1136
1137
1138

-- First, a turgid special case.  When we are generating the
-- standard code and info-table for Vaps (which is done when the function
-- defn is encountered), we don't have a convenient Id to hand whose
-- type is that of (f x y z).  So we need to figure out the type
-- rather than take it from the Id. The Id is probably just "f"!

closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
1139
  = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id)
1140

1141
closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id)
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
\end{code}

@closureReturnsUnboxedType@ is used to check whether a closure, {\em
once it has eaten its arguments}, returns an unboxed type.  For
example, the closure for a function:
\begin{verbatim}
	f :: Int -> Int#
\end{verbatim}
returns an unboxed type.  This is important when dealing with stack
overflow checks.
\begin{code}
closureReturnsUnboxedType :: ClosureInfo -> Bool

closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
1156
  = isPrimType (fun_result_ty arity fun_id)
1157
1158
1159
1160

closureReturnsUnboxedType other_closure = False
	-- All non-function closures aren't functions,
	-- and hence are boxed, since they are heap alloc'd
1161
1162
1163
1164
1165

-- ToDo: need anything like this in Type.lhs?
fun_result_ty arity id
  = let
	(_, de_foralld_ty) = splitForAllTy (idType id)
1166
	(arg_tys, res_ty)  = splitFunTyWithDictsAsArgs de_foralld_ty
1167
1168
1169
    in
    ASSERT(arity >= 0 && length arg_tys >= arity)
    mkFunTys (drop arity arg_tys) res_ty
1170
1171
1172
1173
1174
1175
1176
\end{code}

\begin{code}
closureSemiTag :: ClosureInfo -> Int

closureSemiTag (MkClosureInfo _ lf_info _)
  = case lf_info of
1177
      LFCon data_con _ -> dataConTag data_con - fIRST_TAG
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
      LFTuple _ _      -> 0
      _	    	       -> fromInteger oTHER_TAG
\end{code}

Label generation.

\begin{code}
infoTableLabelFromCI :: ClosureInfo -> CLabel

infoTableLabelFromCI (MkClosureInfo id lf_info rep)
  = case lf_info of
	LFCon con _ 	-> mkConInfoPtr con rep
	LFTuple tup _	-> mkConInfoPtr tup rep

	LFBlackHole     -> mkBlackHoleInfoTableLabel

	LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
1195
					-- Use the standard vap info table
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
					-- for the function, rather than a one-off one
					-- for this particular closure

{-	For now, we generate individual info table and entry code for selector thunks,
	so their info table should be labelled in the standard way.
	The only special thing about them is that the info table has a field which
	tells the GC that it really is a selector.

	Later, perhaps, we'll have some standard RTS code for selector-thunk info tables,
	in which case this line will spring back to life.

	LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset
					-- Ditto for selectors
-}

1211
	other -> {-NO: if isStaticRep rep
1212
		 then mkStaticInfoTableLabel id
1213
		 else -} mkInfoTableLabel id
1214
1215

mkConInfoPtr :: Id -> SMRep -> CLabel
1216
1217
mkConInfoPtr id rep =
  case rep of
1218
1219
1220
1221
1222
    PhantomRep	    -> mkPhantomInfoTableLabel id
    StaticRep _ _   -> mkStaticInfoTableLabel  id
    _		    -> mkInfoTableLabel	       id

mkConEntryPtr :: Id -> SMRep -> CLabel
1223
1224
mkConEntryPtr id rep =
  case rep of
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
    StaticRep _ _   -> mkStaticConEntryLabel id
    _		    -> mkConEntryLabel id


closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id

entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
  = case lf_info of
	LFThunk _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
	LFCon con _			   -> mkConEntryPtr con rep
	LFTuple tup _			   -> mkConEntryPtr tup rep
	other				   -> mkStdEntryLabel id

-- thunkEntryLabel is a local help function, not exported.  It's used from both
-- entryLabelFromCI and getEntryConvention.
-- I don't think it needs to deal with the SelectorThunk case
-- Well, it's falling over now, so I've made it deal with it.  (JSM)

1244
thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
1245
  = mkVapEntryLabel fun_id is_updatable
1246
thunkEntryLabel thunk_id _ is_updatable
1247
  = mkStdEntryLabel thunk_id
1248

1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
fastLabelFromCI :: ClosureInfo -> CLabel
fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
  where
    arity_maybe = arityMaybe (getIdArity id)
    fun_arity	= case arity_maybe of
		    Just x -> x
		    _	   -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id)
\end{code}

\begin{code}
allocProfilingMsg :: ClosureInfo -> FAST_STRING

allocProfilingMsg (MkClosureInfo _ lf_info _)
  = case lf_info of
      LFReEntrant _ _ _		-> SLIT("ALLOC_FUN")
      LFCon _ _			-> SLIT("ALLOC_CON")
      LFTuple _ _		-> SLIT("ALLOC_CON")
      LFThunk _ _ _ _ 		-> SLIT("ALLOC_THK")
      LFBlackHole		-> SLIT("ALLOC_BH")
      LFImported		-> panic "ALLOC_IMP"
\end{code}

1271
1272
We need a black-hole closure info to pass to @allocDynClosure@ when we
want to allocate the black hole on entry to a CAF.
1273
1274

\begin{code}
1275
1276
blackHoleClosureInfo (MkClosureInfo id _ _)
  = MkClosureInfo id LFBlackHole BlackHoleRep
1277
1278
\end{code}

1279
1280
1281
1282
The register liveness when returning from a constructor.  For
simplicity, we claim just [node] is live for all but PhantomRep's.  In
truth, this means that non-constructor info tables also claim node,
but since their liveness information is never used, we don't care.
1283
1284

\begin{code}
1285
1286
1287
dataConLiveness (MkClosureInfo con _ PhantomRep)
  = case (dataReturnConvAlg con) of
      ReturnInRegs regs -> mkLiveRegsMask regs
1288
1289
      ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"

1290
dataConLiveness _ = mkLiveRegsMask [node]
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
\end{code}

%************************************************************************
%*									*
\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
%*									*
%************************************************************************

Profiling requires three pices of information to be determined for
each closure's info table --- kind, description and type.

The description is stored directly in the @CClosureInfoTable@ when the
info table is built.

The kind is determined from the @LambdaForm@ stored in the closure
info using @closureKind@.

The type is determined from the type information stored with the @Id@
in the closure info using @closureTypeDescr@.

\begin{code}
closureKind :: ClosureInfo -> String

closureKind (MkClosureInfo _ lf _)
  = case lf of
      LFReEntrant _ n _		-> if n > 0 then "FN_K" else "THK_K"
      LFCon _ _			-> "CON_K"
      LFTuple _ _		-> "CON_K"
      LFThunk _ _ _ _ 		-> "THK_K"
      LFBlackHole		-> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
      LFImported		-> panic "IMP_KIND"

closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
  = if (isDataCon id) then			-- DataCon has function types
1326
	_UNPK_ (getLocalName (dataConTyCon id))	-- We want the TyCon not the ->
1327
    else
1328
	getTyDescription (idType id)
1329
\end{code}