StgCmmClosure.hs 31.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
-----------------------------------------------------------------------------
--
-- Stg to C-- code generation:
-- 
-- The types   LambdaFormInfo
--             ClosureInfo
--
-- Nothing monadic in here!
--
-----------------------------------------------------------------------------

Simon Marlow's avatar
Simon Marlow committed
12
{-# LANGUAGE RecordWildCards #-}
13
module StgCmmClosure (
Simon Marlow's avatar
Simon Marlow committed
14
        DynTag,  tagForCon, isSmallFamily,
15
16
	ConTagZ, dataConTagZ,

Simon Marlow's avatar
Simon Marlow committed
17
        isVoidRep, isGcPtrRep, addIdReps, addArgReps,
18
19
	argPrimRep, 

20
21
        -- * LambdaFormInfo
        LambdaFormInfo,         -- Abstract
22
23
24
	StandardFormInfo,	-- ...ditto...
	mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
	mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
Simon Marlow's avatar
Simon Marlow committed
25
26
27
        mkLFBlackHole,
        lfDynTag,
        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
28

29
30
31
32
33
34
        nodeMustPointToIt,
        CallMethod(..), getCallMethod,

        isKnownFun, funTag, tagForArity,

        -- * ClosureInfo
35
	ClosureInfo,
Simon Marlow's avatar
Simon Marlow committed
36
        mkClosureInfo,
37
        mkCmmInfo,
38

39
40
        -- ** Inspection
        closureLFInfo, closureName,
Simon Marlow's avatar
Simon Marlow committed
41

42
43
44
        -- ** Labels
        -- These just need the info table label
        closureInfoLabel, staticClosureLabel,
Simon Marlow's avatar
Simon Marlow committed
45
        closureRednCountsLabel, closureSlowEntryLabel, closureLocalEntryLabel,
46

47
48
        -- ** Predicates
        -- These are really just functions on LambdaFormInfo
Simon Marlow's avatar
Simon Marlow committed
49
        closureUpdReqd, closureSingleEntry,
50
51
        closureReEntrant, closureFunInfo,
        isToplevClosure,
52

53
54
        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep
        isStaticClosure,   -- Needs SMPre
55

56
        -- * InfoTables
57
        mkDataConInfoTable,
58
59
        cafBlackHoleInfoTable,
        staticClosureNeedsLink,
60
61
62
63
64
65
66
67
68
    ) where

#include "../includes/MachDeps.h"

#define FAST_STRING_NOT_NEEDED
#include "HsVersions.h"

import StgSyn
import SMRep
69
import Cmm
70
71
72
73
74
75
76
77
78
79
80
81
82
83

import CLabel
import StaticFlags
import Id
import IdInfo
import DataCon
import Name
import Type
import TypeRep
import TcType
import TyCon
import BasicTypes
import Outputable
import Constants
84
import DynFlags
85
86
87
88
89

-----------------------------------------------------------------------------
--		Representations
-----------------------------------------------------------------------------

90
91
-- Why are these here?

92
93
94
95
96
97
98
99
100
101
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
addIdReps :: [Id] -> [(PrimRep, Id)]
addIdReps ids = [(idPrimRep id, id) | id <- ids]

addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
addArgReps args = [(argPrimRep arg, arg) | arg <- args]

argPrimRep :: StgArg -> PrimRep
argPrimRep arg = typePrimRep (stgArgType arg)

isVoidRep :: PrimRep -> Bool
isVoidRep VoidRep = True
isVoidRep _other  = False

isGcPtrRep :: PrimRep -> Bool
isGcPtrRep PtrRep = True
isGcPtrRep _      = False


-----------------------------------------------------------------------------
--		LambdaFormInfo
-----------------------------------------------------------------------------

-- Information about an identifier, from the code generator's point of
-- view.  Every identifier is bound to a LambdaFormInfo in the
-- environment, which gives the code generator enough info to be able to
-- tail call or return that identifier.

data LambdaFormInfo
  = LFReEntrant		-- Reentrant closure (a function)
	TopLevelFlag	-- True if top level
	!Int		-- Arity. Invariant: always > 0
	!Bool		-- True <=> no fvs
	ArgDescr	-- Argument descriptor (should really be in ClosureInfo)

  | LFThunk		-- Thunk (zero arity)
	TopLevelFlag
	!Bool		-- True <=> no free vars
	!Bool		-- True <=> updatable (i.e., *not* single-entry)
	StandardFormInfo
	!Bool		-- True <=> *might* be a function type

  | LFCon		-- A saturated constructor application
	DataCon		-- The constructor

  | LFUnknown		-- Used for function arguments and 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)
	!Bool		-- True <=> *might* be a function type
			--      The False case is good when we want to enter it,
			--	because then we know the entry code will do
			--	For a function, the entry code is the fast entry point

  | LFUnLifted		-- A value of unboxed type; 
			-- always a value, neeeds evaluation

  | LFLetNoEscape	-- See LetNoEscape module for precise description 

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

Simon Marlow's avatar
Simon Marlow committed
156
157
158
                        -- XXX we can very nearly get rid of this, but
                        -- allocDynClosure needs a LambdaFormInfo

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

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

data StandardFormInfo
  = NonStandardThunk
	-- Not of of the standard forms

  | SelectorThunk
	-- A SelectorThunk is of form
	--      case x of
	--	       con a1,..,an -> ak
	-- and the constructor is from a single-constr type.
       WordOff         	-- 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.)

  | ApThunk 
	-- An ApThunk is of form
	--	x1 ... xn
	-- The code for the thunk just pushes x2..xn on the stack and enters x1.
	-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
	-- in the RTS to save space.
	Int		-- Arity, n


------------------------------------------------------
--		Building LambdaFormInfo
------------------------------------------------------

mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id 
  | isUnLiftedType ty  	   = LFUnLifted
  | might_be_a_function ty = LFUnknown True
  | otherwise 		   = LFUnknown False
  where
    ty = idType id

-------------
mkLFLetNoEscape :: LambdaFormInfo
mkLFLetNoEscape = LFLetNoEscape

-------------
mkLFReEntrant :: TopLevelFlag	-- True of top level
204
	      -> [Id]	        -- Free vars
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
	      -> [Id] 		-- Args
	      -> ArgDescr	-- Argument descriptor
	      -> LambdaFormInfo

mkLFReEntrant top fvs args arg_descr 
  = LFReEntrant top (length args) (null fvs) arg_descr

-------------
mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk thunk_ty top fvs upd_flag
  = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
    LFThunk top (null fvs) 
	    (isUpdatable upd_flag)
	    NonStandardThunk 
	    (might_be_a_function thunk_ty)

--------------
might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
226
227
228
  = case tyConAppTyCon_maybe (repType ty) of
	Just tc -> not (isDataTyCon tc)
	Nothing -> True
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

-------------
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con = LFCon con

-------------
mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
mkSelectorLFInfo id offset updatable
  = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
	(might_be_a_function (idType id))

-------------
mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
mkApLFInfo id upd_flag arity
  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
	(might_be_a_function (idType id))

-------------
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
  | Just con <- isDataConWorkId_maybe id
  , isNullaryRepDataCon con
  = LFCon con	-- An imported nullary constructor
		-- We assume that the constructor is evaluated so that
		-- the id really does point directly to the constructor

  | arity > 0
  = LFReEntrant TopLevel arity True (panic "arg_descr")

  | otherwise
  = mkLFArgument id -- Not sure of exact arity
  where
    arity = idArity id

Simon Marlow's avatar
Simon Marlow committed
263
264
265
266
------------
mkLFBlackHole :: LambdaFormInfo
mkLFBlackHole = LFBlackHole

267
268
269
270
271
272
273
274
275
276
277
-----------------------------------------------------
--		Dynamic pointer tagging
-----------------------------------------------------

type ConTagZ = Int	-- A *zero-indexed* contructor tag

type DynTag = Int	-- The tag on a *pointer*
			-- (from the dynamic-tagging paper)

{- 	Note [Data constructor dynamic tags]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
278
279
The family size of a data type (the number of constructors
or the arity of a function) can be either:
280
281
282
283
    * small, if the family size < 2**tag_bits
    * big, otherwise.

Small families can have the constructor tag in the tag bits.
284
285
286
Big families only use the tag value 1 to represent evaluatedness.
We don't have very many tag bits: for example, we have 2 bits on
x86-32 and 3 bits on x86-64. -}
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308

isSmallFamily :: Int -> Bool
isSmallFamily fam_size = fam_size <= mAX_PTR_TAG

-- We keep the *zero-indexed* tag in the srt_len field of the info
-- table of a data constructor.
dataConTagZ :: DataCon -> ConTagZ
dataConTagZ con = dataConTag con - fIRST_TAG

tagForCon :: DataCon -> DynTag
tagForCon con 
  | isSmallFamily fam_size = con_tag + 1
  | otherwise		   = 1
  where
    con_tag  = dataConTagZ con
    fam_size = tyConFamilySize (dataConTyCon con)

tagForArity :: Int -> DynTag
tagForArity arity | isSmallFamily arity = arity
                  | otherwise           = 0

lfDynTag :: LambdaFormInfo -> DynTag
309
310
-- Return the tag in the low order bits of a variable bound
-- to this LambdaForm
311
312
lfDynTag (LFCon con)               = tagForCon con
lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
313
314
315
316
317
318
319
320
321
322
323
324
325
326
lfDynTag _other                    = 0


-----------------------------------------------------------------------------
--		Observing LambdaFormInfo
-----------------------------------------------------------------------------

-------------
maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
maybeIsLFCon (LFCon con) = Just con
maybeIsLFCon _ = Nothing

------------
isLFThunk :: LambdaFormInfo -> Bool
327
328
isLFThunk (LFThunk {})  = True
isLFThunk LFBlackHole   = True
329
330
331
332
333
	-- return True for a blackhole: this function is used to determine
	-- whether to use the thunk header in SMP mode, and a blackhole
	-- must have one.
isLFThunk _ = False

334
335
336
isLFReEntrant :: LambdaFormInfo -> Bool
isLFReEntrant (LFReEntrant {}) = True
isLFReEntrant _                = False
337
338
339
340
341

-----------------------------------------------------------------------------
--		Choosing SM reps
-----------------------------------------------------------------------------

342
343
lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
344
345
lfClosureType (LFCon con)                  = Constr (fromIntegral (dataConTagZ con))
                                                      (dataConIdentity con)
346
347
348
349
350
351
lfClosureType (LFThunk _ _ _ is_sel _) 	   = thunkClosureType is_sel
lfClosureType _                 	   = panic "lfClosureType"

thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
thunkClosureType _                   = Thunk
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403

-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
-- gets compiled to a jump to g (if g has non-zero arity), instead of
-- messing around with update frames and PAPs.  We set the closure type
-- to FUN_STATIC in this case.

-----------------------------------------------------------------------------
--		nodeMustPointToIt
-----------------------------------------------------------------------------

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

nodeMustPointToIt :: LambdaFormInfo -> Bool
nodeMustPointToIt (LFReEntrant top _ no_fvs _)
  = not no_fvs ||   -- Certainly if it has fvs we need to point to it
    isNotTopLevel 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.

nodeMustPointToIt (LFCon _) = 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.

nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
  = updatable || not no_fvs || opt_SccProfilingOn
	  -- 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)

nodeMustPointToIt (LFThunk {})	-- Node must point to a standard-form thunk
  = True 

nodeMustPointToIt (LFUnknown _)   = True
nodeMustPointToIt LFUnLifted      = False
404
nodeMustPointToIt LFBlackHole     = True    -- BH entry may require Node to point
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
nodeMustPointToIt LFLetNoEscape   = False 

-----------------------------------------------------------------------------
--		getCallMethod
-----------------------------------------------------------------------------

{- 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.

Closure 			      Node   Argument   Enter
Characteristics  		Par   Req'd  Passing    Via
-------------------------------------------------------------------------------
Unknown 			& no & yes & stack	& node
Known fun (>1 arg), no fvs 	& no & no  & registers 	& fast entry (enough args)
							& slow entry (otherwise)
Known fun (>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 (>1 arg), no fvs 	& yes & no  & registers & fast entry (enough args)
	 						& slow entry (otherwise)
Known fun (>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}

When black-holing, single-entry closures could also be entered via node
(rather than directly) to catch double-entry. -}

data CallMethod
  = EnterIt		-- No args, not a function

  | JumpToIt		-- A join point 

  | ReturnIt		-- It's a value (function, unboxed value,
			-- or constructor), so just return it.

  | SlowCall		-- Unknown fun, or known fun with
			-- too few args.

  | DirectEntry 	-- Jump directly, with args in regs
	CLabel 		--   The code label
	Int 		--   Its arity

455
456
getCallMethod :: DynFlags
              -> Name           -- Function being applied
457
458
459
460
461
              -> CafInfo        -- Can it refer to CAF's?
	      -> LambdaFormInfo	-- Its info
	      -> Int		-- Number of available arguments
	      -> CallMethod

462
getCallMethod _ _name _ lf_info _n_args
463
464
465
466
467
468
  | nodeMustPointToIt lf_info && opt_Parallel
  =	-- If we're parallel, then we must always enter via node.  
	-- The reason is that the closure may have been 	
	-- fetched since we allocated it.
    EnterIt

469
getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
470
471
472
  | n_args == 0    = ASSERT( arity /= 0 )
		     ReturnIt	-- No args at all
  | n_args < arity = SlowCall	-- Not enough args
473
  | otherwise      = DirectEntry (enterIdLabel name caf) arity
474

475
getCallMethod _ _name _ LFUnLifted n_args
476
477
  = ASSERT( n_args == 0 ) ReturnIt

478
getCallMethod _ _name _ (LFCon _) n_args
479
480
  = ASSERT( n_args == 0 ) ReturnIt

481
getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
482
483
484
485
486
  | is_fun 	-- it *might* be a function, so we must "call" it (which is always safe)
  = SlowCall	-- We cannot just enter it [in eval/apply, the entry code
		-- is the fast-entry code]

  -- Since is_fun is False, we are *definitely* looking at a data value
487
  | updatable || doingTickyProfiling dflags -- to catch double entry
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
      {- OLD: || opt_SMP
	 I decided to remove this, because in SMP mode it doesn't matter
	 if we enter the same thunk multiple times, so the optimisation
	 of jumping directly to the entry code is still valid.  --SDM
	-}
  = EnterIt
    -- We used to have ASSERT( n_args == 0 ), but actually it is
    -- possible for the optimiser to generate
    --   let bot :: Int = error Int "urk"
    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
    -- This happens as a result of the case-of-error transformation
    -- So the right thing to do is just to enter the thing

  | otherwise	-- Jump direct to code for single-entry thunks
  = ASSERT( n_args == 0 )
    DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0

505
getCallMethod _ _name _ (LFUnknown True) _n_args
506
507
  = SlowCall -- might be a function

508
getCallMethod _ name _ (LFUnknown False) n_args
509
510
511
  = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) 
    EnterIt -- Not a function

512
getCallMethod _ _name _ LFBlackHole _n_args
513
514
515
516
  = SlowCall	-- Presumably the black hole has by now
		-- been updated, but we don't know with
		-- what, so we slow call it

517
getCallMethod _ _name _ LFLetNoEscape _n_args
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
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
  = JumpToIt

isKnownFun :: LambdaFormInfo -> Bool
isKnownFun (LFReEntrant _ _ _ _) = True
isKnownFun LFLetNoEscape	 = True
isKnownFun _ = False

-----------------------------------------------------------------------------
--		staticClosureRequired
-----------------------------------------------------------------------------

{-  staticClosureRequired is never called (hence commented out)

    SimonMar writes (Sept 07) It's an optimisation we used to apply at
    one time, I believe, but it got lost probably in the rewrite of
    the RTS/code generator.  I left that code there to remind me to
    look into whether it was worth doing sometime

{- 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)

  Why case (a) here?  Because if the arg-satis check fails,
  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.]

  [NB: these conditions imply that we might need the closure
  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)

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

staticClosureRequired
	:: Name
	-> StgBinderInfo
	-> LambdaFormInfo
	-> Bool
staticClosureRequired binder bndr_info
		      (LFReEntrant top_level _ _ _)	-- It's a function
  = ASSERT( isTopLevel top_level )
	-- Assumption: it's a top-level, no-free-var binding
	not (satCallsOnly bndr_info)

staticClosureRequired binder other_binder_info other_lf_info = True
-}

-----------------------------------------------------------------------------
612
--              Data types for closure information
613
614
615
-----------------------------------------------------------------------------


616
{- ClosureInfo: information about a binding
617

618
619
620
   We make a ClosureInfo for each let binding (both top level and not),
   but not bindings for data constructors: for those we build a CmmInfoTable
   directly (see mkDataConInfoTable).
621

622
623
   To a first approximation:
       ClosureInfo = (LambdaFormInfo, CmmInfoTable)
Simon Marlow's avatar
Simon Marlow committed
624

625
626
627
628
629
   A ClosureInfo has enough information
     a) to construct the info table itself, and build other things
        related to the binding (e.g. slow entry points for a function)
     b) to allocate a closure containing that info pointer (i.e.
   	it knows the info table label)
630
631
632
633
-}

data ClosureInfo
  = ClosureInfo {
634
635
636
637
638
639
640
641
642
643
644
645
646
        closureName :: !Name,           -- The thing bound to this closure
           -- we don't really need this field: it's only used in generating
           -- code for ticky and profiling, and we could pass the information
           -- around separately, but it doesn't do much harm to keep it here.

        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
          -- this tells us about what the closure contains: it's right-hand-side.

          -- the rest is just an unpacked CmmInfoTable.
        closureInfoLabel :: !CLabel,
        closureSMRep     :: !SMRep,          -- representation used by storage mgr
        closureSRT       :: !C_SRT,          -- What SRT applies to this closure
        closureProf      :: !ProfilingInfo
647
648
    }

Simon Marlow's avatar
Simon Marlow committed
649
650
-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
mkCmmInfo :: ClosureInfo -> CmmInfoTable
651
652
653
654
655
mkCmmInfo ClosureInfo {..}
  = CmmInfoTable { cit_lbl  = closureInfoLabel
                 , cit_rep  = closureSMRep
                 , cit_prof = closureProf
                 , cit_srt  = closureSRT }
Simon Marlow's avatar
Simon Marlow committed
656

657
658
659
660
661
662
663
664
665
666
667
668

--------------------------------------
--	Building ClosureInfos
--------------------------------------

mkClosureInfo :: Bool		-- Is static
	      -> Id
	      -> LambdaFormInfo 
	      -> Int -> Int	-- Total and pointer words
	      -> C_SRT
	      -> String		-- String descriptor
	      -> ClosureInfo
669
mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info val_descr
670
671
672
673
674
675
  = ClosureInfo { closureName      = name,
                  closureLFInfo    = lf_info,
                  closureInfoLabel = info_lbl,
                  closureSMRep     = sm_rep,    -- These four fields are a
                  closureSRT       = srt_info,  --        CmmInfoTable
                  closureProf      = prof }     -- ---
676
  where
Simon Marlow's avatar
Simon Marlow committed
677
678
679
    name       = idName id
    sm_rep     = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
    prof       = mkProfilingInfo id val_descr
680
    nonptr_wds = tot_wds - ptr_wds
681

682
    info_lbl = mkClosureInfoTableLabel id lf_info
683
684

--------------------------------------
685
--   Other functions over ClosureInfo
686
687
--------------------------------------

688
689
690
-- Eager blackholing is normally disabled, but can be turned on with
-- -feager-blackholing.  When it is on, we replace the info pointer of
-- the thunk with stg_EAGER_BLACKHOLE_info on entry.
691

692
693
694
695
696
697
698
699
700
701
702
-- If we wanted to do eager blackholing with slop filling,
-- we'd need to do it at the *end* of a basic block, otherwise
-- we overwrite the free variables in the thunk that we still
-- need.  We have a patch for this from Andy Cheadle, but not
-- incorporated yet. --SDM [6/2004]
--
--
-- Previously, eager blackholing was enabled when ticky-ticky
-- was on. But it didn't work, and it wasn't strictly necessary 
-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING 
-- is unconditionally disabled. -- krc 1/2007
703
704
705

-- Static closures are never themselves black-holed.

706
707
blackHoleOnEntry :: ClosureInfo -> Bool
blackHoleOnEntry cl_info
708
  | isStaticRep (closureSMRep cl_info)
709
710
711
  = False	-- Never black-hole a static closure

  | otherwise
712
  = case closureLFInfo cl_info of
713
714
	LFReEntrant _ _ _ _	  -> False
	LFLetNoEscape 		  -> False
715
        LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks.
716
        _other -> panic "blackHoleOnEntry"      -- Should never happen
717
718
719
720
721
722
723
724
725

isStaticClosure :: ClosureInfo -> Bool
isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)

closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info

lfUpdatable :: LambdaFormInfo -> Bool
lfUpdatable (LFThunk _ _ upd _ _)  = upd
726
lfUpdatable LFBlackHole 	   = True
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
	-- Black-hole closures are allocated to receive the results of an
	-- alg case with a named default... so they need to be updated.
lfUpdatable _ = False

closureSingleEntry :: ClosureInfo -> Bool
closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
closureSingleEntry _ = False

closureReEntrant :: ClosureInfo -> Bool
closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant _ = False

closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info

lfFunInfo :: LambdaFormInfo ->  Maybe (Int, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
lfFunInfo _                                 = Nothing

funTag :: ClosureInfo -> DynTag
funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info

isToplevClosure :: ClosureInfo -> Bool
isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
  = case lf_info of
      LFReEntrant TopLevel _ _ _ -> True
      LFThunk TopLevel _ _ _ _   -> True
      _other			 -> False

--------------------------------------
--   Label generation
--------------------------------------

Simon Marlow's avatar
Simon Marlow committed
760
staticClosureLabel :: ClosureInfo -> CLabel
761
staticClosureLabel = toClosureLbl .  closureInfoLabel
Simon Marlow's avatar
Simon Marlow committed
762
763

closureRednCountsLabel :: ClosureInfo -> CLabel
764
closureRednCountsLabel = toRednCountsLbl . closureInfoLabel
Simon Marlow's avatar
Simon Marlow committed
765
766

closureSlowEntryLabel :: ClosureInfo -> CLabel
767
closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
Simon Marlow's avatar
Simon Marlow committed
768
769

closureLocalEntryLabel :: ClosureInfo -> CLabel
770
771
772
closureLocalEntryLabel
  | tablesNextToCode = toInfoLbl  . closureInfoLabel
  | otherwise        = toEntryLbl . closureInfoLabel
batterseapower's avatar
batterseapower committed
773

774
775
mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
mkClosureInfoTableLabel id lf_info
batterseapower's avatar
batterseapower committed
776
  = case lf_info of
777
        LFBlackHole -> mkCAFBlackHoleInfoTableLabel
778

779
	LFThunk _ _ upd_flag (SelectorThunk offset) _ 
780
                      -> mkSelectorInfoLabel upd_flag offset
781

782
	LFThunk _ _ upd_flag (ApThunk arity) _ 
783
                      -> mkApInfoTableLabel upd_flag arity
784

785
786
        LFThunk{}     -> std_mk_lbl name cafs
        LFReEntrant{} -> std_mk_lbl name cafs
Simon Marlow's avatar
Simon Marlow committed
787
        _other        -> panic "closureInfoTableLabel"
788

789
  where 
790
791
    name = idName id

Simon Marlow's avatar
Simon Marlow committed
792
    std_mk_lbl | is_local  = mkLocalInfoTableLabel
793
794
               | otherwise = mkInfoTableLabel

795
796
797
798
799
800
801
    cafs     = idCafInfo id
    is_local = isDataConWorkId id
       -- Make the _info pointer for the implicit datacon worker
       -- binding local. The reason we can do this is that importing
       -- code always either uses the _closure or _con_info. By the
       -- invariants in CorePrep anything else gets eta expanded.

802
803

thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
Simon Marlow's avatar
Simon Marlow committed
804
805
-- thunkEntryLabel is a local help function, not exported.  It's used from
-- getCallMethod.
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
thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
  = enterApLabel upd_flag arity
thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
  = enterSelectorLabel upd_flag offset
thunkEntryLabel thunk_id c _ _
  = enterIdLabel thunk_id c

enterApLabel :: Bool -> Arity -> CLabel
enterApLabel is_updatable arity
  | tablesNextToCode = mkApInfoTableLabel is_updatable arity
  | otherwise        = mkApEntryLabel is_updatable arity

enterSelectorLabel :: Bool -> WordOff -> CLabel
enterSelectorLabel upd_flag offset
  | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
  | otherwise        = mkSelectorEntryLabel upd_flag offset

enterIdLabel :: Name -> CafInfo -> CLabel
enterIdLabel id c
  | tablesNextToCode = mkInfoTableLabel id c
  | otherwise        = mkEntryLabel id c


--------------------------------------
--   Profiling
--------------------------------------

-- Profiling requires two pieces of information to be determined for
-- each closure's info table --- description and type.

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

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

842
843
844
845
846
847
848
mkProfilingInfo :: Id -> String -> ProfilingInfo
mkProfilingInfo id val_descr
  | not opt_SccProfilingOn = NoProfilingInfo
  | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
  where
    ty_descr_w8  = stringToWord8s (getTyDescription (idType id))
    val_descr_w8 = stringToWord8s val_descr
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863

getTyDescription :: Type -> String
getTyDescription ty
  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
    case tau_ty of
      TyVarTy _	       	     -> "*"
      AppTy fun _      	     -> getTyDescription fun
      FunTy _ res      	     -> '-' : '>' : fun_result res
      TyConApp tycon _ 	     -> getOccString tycon
      ForAllTy _ ty          -> getTyDescription ty
    }
  where
    fun_result (FunTy _ res) = '>' : fun_result res
    fun_result other	     = getTyDescription other

864
--------------------------------------
Simon Marlow's avatar
Simon Marlow committed
865
--   CmmInfoTable-related things
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
--------------------------------------

mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable data_con is_static ptr_wds nonptr_wds
 = CmmInfoTable { cit_lbl  = info_lbl
                , cit_rep  = sm_rep
                , cit_prof = prof
                , cit_srt  = NoC_SRT }
 where
   name = dataConName data_con

   info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs
            | otherwise = mkConInfoTableLabel    name NoCafRefs

   sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type

   cl_type = Constr (fromIntegral (dataConTagZ data_con))
                   (dataConIdentity data_con)

   prof | not opt_SccProfilingOn = NoProfilingInfo
        | otherwise              = ProfilingInfo ty_descr val_descr

   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
   val_descr = stringToWord8s $ occNameString $ getOccName data_con
Simon Marlow's avatar
Simon Marlow committed
890

Simon Marlow's avatar
Simon Marlow committed
891
892
893
894
895
896
897
898
899
-- We need a black-hole closure info to pass to @allocDynClosure@ when we
-- want to allocate the black hole on entry to a CAF.

cafBlackHoleInfoTable :: CmmInfoTable
cafBlackHoleInfoTable
  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
                 , cit_rep  = blackHoleRep
                 , cit_prof = NoProfilingInfo
                 , cit_srt  = NoC_SRT }
Simon Marlow's avatar
Simon Marlow committed
900
901
902
903
904
905
906
907
908
909
910
911

staticClosureNeedsLink :: CmmInfoTable -> Bool
-- A static closure needs a link field to aid the GC when traversing
-- the static closure graph.  But it only needs such a field if either
-- 	a) it has an SRT
--	b) it's a constructor with one or more pointer fields
-- In case (b), the constructor's fields themselves play the role
-- of the SRT.
staticClosureNeedsLink info_tbl@CmmInfoTable{ cit_rep = smrep }
  | isConRep smrep         = not (isStaticNoCafCon smrep)
  | otherwise              = needsSRT (cit_srt info_tbl)
staticClosureNeedsLink _ = False
Simon Marlow's avatar
Simon Marlow committed
912