fix the eager-blackholing check, which I inadvertently broke in
[ghc.git] / compiler / codeGen / StgCmmClosure.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation:
4 --
5 -- The types LambdaFormInfo
6 -- ClosureInfo
7 --
8 -- Nothing monadic in here!
9 --
10 -----------------------------------------------------------------------------
11
12 {-# LANGUAGE RecordWildCards #-}
13 module StgCmmClosure (
14 DynTag, tagForCon, isSmallFamily,
15 ConTagZ, dataConTagZ,
16
17 isVoidRep, isGcPtrRep, addIdReps, addArgReps,
18 argPrimRep,
19
20 -- * LambdaFormInfo
21 LambdaFormInfo, -- Abstract
22 StandardFormInfo, -- ...ditto...
23 mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
24 mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
25 mkLFBlackHole,
26 lfDynTag,
27 maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
28
29 nodeMustPointToIt,
30 CallMethod(..), getCallMethod,
31
32 isKnownFun, funTag, tagForArity,
33
34 -- * ClosureInfo
35 ClosureInfo,
36 mkClosureInfo,
37 mkCmmInfo,
38
39 -- ** Inspection
40 closureLFInfo, closureName,
41
42 -- ** Labels
43 -- These just need the info table label
44 closureInfoLabel, staticClosureLabel,
45 closureRednCountsLabel, closureSlowEntryLabel, closureLocalEntryLabel,
46
47 -- ** Predicates
48 -- These are really just functions on LambdaFormInfo
49 closureUpdReqd, closureSingleEntry,
50 closureReEntrant, closureFunInfo,
51 isToplevClosure,
52
53 blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep
54 isStaticClosure, -- Needs SMPre
55
56 -- * InfoTables
57 mkDataConInfoTable,
58 cafBlackHoleInfoTable,
59 staticClosureNeedsLink,
60 ) where
61
62 #include "../includes/MachDeps.h"
63
64 #define FAST_STRING_NOT_NEEDED
65 #include "HsVersions.h"
66
67 import StgSyn
68 import SMRep
69 import Cmm
70
71 import CLabel
72 import StaticFlags
73 import Id
74 import IdInfo
75 import DataCon
76 import Name
77 import Type
78 import TypeRep
79 import TcType
80 import TyCon
81 import BasicTypes
82 import Outputable
83 import Constants
84 import DynFlags
85
86 -----------------------------------------------------------------------------
87 -- Representations
88 -----------------------------------------------------------------------------
89
90 -- Why are these here?
91
92 addIdReps :: [Id] -> [(PrimRep, Id)]
93 addIdReps ids = [(idPrimRep id, id) | id <- ids]
94
95 addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
96 addArgReps args = [(argPrimRep arg, arg) | arg <- args]
97
98 argPrimRep :: StgArg -> PrimRep
99 argPrimRep arg = typePrimRep (stgArgType arg)
100
101 isVoidRep :: PrimRep -> Bool
102 isVoidRep VoidRep = True
103 isVoidRep _other = False
104
105 isGcPtrRep :: PrimRep -> Bool
106 isGcPtrRep PtrRep = True
107 isGcPtrRep _ = False
108
109
110 -----------------------------------------------------------------------------
111 -- LambdaFormInfo
112 -----------------------------------------------------------------------------
113
114 -- Information about an identifier, from the code generator's point of
115 -- view. Every identifier is bound to a LambdaFormInfo in the
116 -- environment, which gives the code generator enough info to be able to
117 -- tail call or return that identifier.
118
119 data LambdaFormInfo
120 = LFReEntrant -- Reentrant closure (a function)
121 TopLevelFlag -- True if top level
122 !Int -- Arity. Invariant: always > 0
123 !Bool -- True <=> no fvs
124 ArgDescr -- Argument descriptor (should really be in ClosureInfo)
125
126 | LFThunk -- Thunk (zero arity)
127 TopLevelFlag
128 !Bool -- True <=> no free vars
129 !Bool -- True <=> updatable (i.e., *not* single-entry)
130 StandardFormInfo
131 !Bool -- True <=> *might* be a function type
132
133 | LFCon -- A saturated constructor application
134 DataCon -- The constructor
135
136 | LFUnknown -- Used for function arguments and imported things.
137 -- We know nothing about this closure.
138 -- Treat like updatable "LFThunk"...
139 -- Imported things which we *do* know something about use
140 -- one of the other LF constructors (eg LFReEntrant for
141 -- known functions)
142 !Bool -- True <=> *might* be a function type
143 -- The False case is good when we want to enter it,
144 -- because then we know the entry code will do
145 -- For a function, the entry code is the fast entry point
146
147 | LFUnLifted -- A value of unboxed type;
148 -- always a value, neeeds evaluation
149
150 | LFLetNoEscape -- See LetNoEscape module for precise description
151
152 | LFBlackHole -- Used for the closures allocated to hold the result
153 -- of a CAF. We want the target of the update frame to
154 -- be in the heap, so we make a black hole to hold it.
155
156 -- XXX we can very nearly get rid of this, but
157 -- allocDynClosure needs a LambdaFormInfo
158
159
160 -------------------------
161 -- StandardFormInfo tells whether this thunk has one of
162 -- a small number of standard forms
163
164 data StandardFormInfo
165 = NonStandardThunk
166 -- Not of of the standard forms
167
168 | SelectorThunk
169 -- A SelectorThunk is of form
170 -- case x of
171 -- con a1,..,an -> ak
172 -- and the constructor is from a single-constr type.
173 WordOff -- 0-origin offset of ak within the "goods" of
174 -- constructor (Recall that the a1,...,an may be laid
175 -- out in the heap in a non-obvious order.)
176
177 | ApThunk
178 -- An ApThunk is of form
179 -- x1 ... xn
180 -- The code for the thunk just pushes x2..xn on the stack and enters x1.
181 -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
182 -- in the RTS to save space.
183 Int -- Arity, n
184
185
186 ------------------------------------------------------
187 -- Building LambdaFormInfo
188 ------------------------------------------------------
189
190 mkLFArgument :: Id -> LambdaFormInfo
191 mkLFArgument id
192 | isUnLiftedType ty = LFUnLifted
193 | might_be_a_function ty = LFUnknown True
194 | otherwise = LFUnknown False
195 where
196 ty = idType id
197
198 -------------
199 mkLFLetNoEscape :: LambdaFormInfo
200 mkLFLetNoEscape = LFLetNoEscape
201
202 -------------
203 mkLFReEntrant :: TopLevelFlag -- True of top level
204 -> [Id] -- Free vars
205 -> [Id] -- Args
206 -> ArgDescr -- Argument descriptor
207 -> LambdaFormInfo
208
209 mkLFReEntrant top fvs args arg_descr
210 = LFReEntrant top (length args) (null fvs) arg_descr
211
212 -------------
213 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
214 mkLFThunk thunk_ty top fvs upd_flag
215 = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
216 LFThunk top (null fvs)
217 (isUpdatable upd_flag)
218 NonStandardThunk
219 (might_be_a_function thunk_ty)
220
221 --------------
222 might_be_a_function :: Type -> Bool
223 -- Return False only if we are *sure* it's a data type
224 -- Look through newtypes etc as much as poss
225 might_be_a_function ty
226 = case tyConAppTyCon_maybe (repType ty) of
227 Just tc -> not (isDataTyCon tc)
228 Nothing -> True
229
230 -------------
231 mkConLFInfo :: DataCon -> LambdaFormInfo
232 mkConLFInfo con = LFCon con
233
234 -------------
235 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
236 mkSelectorLFInfo id offset updatable
237 = LFThunk NotTopLevel False updatable (SelectorThunk offset)
238 (might_be_a_function (idType id))
239
240 -------------
241 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
242 mkApLFInfo id upd_flag arity
243 = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
244 (might_be_a_function (idType id))
245
246 -------------
247 mkLFImported :: Id -> LambdaFormInfo
248 mkLFImported id
249 | Just con <- isDataConWorkId_maybe id
250 , isNullaryRepDataCon con
251 = LFCon con -- An imported nullary constructor
252 -- We assume that the constructor is evaluated so that
253 -- the id really does point directly to the constructor
254
255 | arity > 0
256 = LFReEntrant TopLevel arity True (panic "arg_descr")
257
258 | otherwise
259 = mkLFArgument id -- Not sure of exact arity
260 where
261 arity = idArity id
262
263 ------------
264 mkLFBlackHole :: LambdaFormInfo
265 mkLFBlackHole = LFBlackHole
266
267 -----------------------------------------------------
268 -- Dynamic pointer tagging
269 -----------------------------------------------------
270
271 type ConTagZ = Int -- A *zero-indexed* contructor tag
272
273 type DynTag = Int -- The tag on a *pointer*
274 -- (from the dynamic-tagging paper)
275
276 {- Note [Data constructor dynamic tags]
277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
278 The family size of a data type (the number of constructors
279 or the arity of a function) can be either:
280 * small, if the family size < 2**tag_bits
281 * big, otherwise.
282
283 Small families can have the constructor tag in the tag bits.
284 Big families only use the tag value 1 to represent evaluatedness.
285 We don't have very many tag bits: for example, we have 2 bits on
286 x86-32 and 3 bits on x86-64. -}
287
288 isSmallFamily :: Int -> Bool
289 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
290
291 -- We keep the *zero-indexed* tag in the srt_len field of the info
292 -- table of a data constructor.
293 dataConTagZ :: DataCon -> ConTagZ
294 dataConTagZ con = dataConTag con - fIRST_TAG
295
296 tagForCon :: DataCon -> DynTag
297 tagForCon con
298 | isSmallFamily fam_size = con_tag + 1
299 | otherwise = 1
300 where
301 con_tag = dataConTagZ con
302 fam_size = tyConFamilySize (dataConTyCon con)
303
304 tagForArity :: Int -> DynTag
305 tagForArity arity | isSmallFamily arity = arity
306 | otherwise = 0
307
308 lfDynTag :: LambdaFormInfo -> DynTag
309 -- Return the tag in the low order bits of a variable bound
310 -- to this LambdaForm
311 lfDynTag (LFCon con) = tagForCon con
312 lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
313 lfDynTag _other = 0
314
315
316 -----------------------------------------------------------------------------
317 -- Observing LambdaFormInfo
318 -----------------------------------------------------------------------------
319
320 -------------
321 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
322 maybeIsLFCon (LFCon con) = Just con
323 maybeIsLFCon _ = Nothing
324
325 ------------
326 isLFThunk :: LambdaFormInfo -> Bool
327 isLFThunk (LFThunk {}) = True
328 isLFThunk LFBlackHole = True
329 -- return True for a blackhole: this function is used to determine
330 -- whether to use the thunk header in SMP mode, and a blackhole
331 -- must have one.
332 isLFThunk _ = False
333
334 isLFReEntrant :: LambdaFormInfo -> Bool
335 isLFReEntrant (LFReEntrant {}) = True
336 isLFReEntrant _ = False
337
338 -----------------------------------------------------------------------------
339 -- Choosing SM reps
340 -----------------------------------------------------------------------------
341
342 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
343 lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
344 lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con))
345 (dataConIdentity con)
346 lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
347 lfClosureType _ = panic "lfClosureType"
348
349 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
350 thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
351 thunkClosureType _ = Thunk
352
353 -- We *do* get non-updatable top-level thunks sometimes. eg. f = g
354 -- gets compiled to a jump to g (if g has non-zero arity), instead of
355 -- messing around with update frames and PAPs. We set the closure type
356 -- to FUN_STATIC in this case.
357
358 -----------------------------------------------------------------------------
359 -- nodeMustPointToIt
360 -----------------------------------------------------------------------------
361
362 -- Be sure to see the stg-details notes about these...
363
364 nodeMustPointToIt :: LambdaFormInfo -> Bool
365 nodeMustPointToIt (LFReEntrant top _ no_fvs _)
366 = not no_fvs || -- Certainly if it has fvs we need to point to it
367 isNotTopLevel top
368 -- If it is not top level we will point to it
369 -- We can have a \r closure with no_fvs which
370 -- is not top level as special case cgRhsClosure
371 -- has been dissabled in favour of let floating
372
373 -- For lex_profiling we also access the cost centre for a
374 -- non-inherited function i.e. not top level
375 -- the not top case above ensures this is ok.
376
377 nodeMustPointToIt (LFCon _) = True
378
379 -- Strictly speaking, the above two don't need Node to point
380 -- to it if the arity = 0. But this is a *really* unlikely
381 -- situation. If we know it's nil (say) and we are entering
382 -- it. Eg: let x = [] in x then we will certainly have inlined
383 -- x, since nil is a simple atom. So we gain little by not
384 -- having Node point to known zero-arity things. On the other
385 -- hand, we do lose something; Patrick's code for figuring out
386 -- when something has been updated but not entered relies on
387 -- having Node point to the result of an update. SLPJ
388 -- 27/11/92.
389
390 nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
391 = updatable || not no_fvs || opt_SccProfilingOn
392 -- For the non-updatable (single-entry case):
393 --
394 -- True if has fvs (in which case we need access to them, and we
395 -- should black-hole it)
396 -- or profiling (in which case we need to recover the cost centre
397 -- from inside it)
398
399 nodeMustPointToIt (LFThunk {}) -- Node must point to a standard-form thunk
400 = True
401
402 nodeMustPointToIt (LFUnknown _) = True
403 nodeMustPointToIt LFUnLifted = False
404 nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point
405 nodeMustPointToIt LFLetNoEscape = False
406
407 -----------------------------------------------------------------------------
408 -- getCallMethod
409 -----------------------------------------------------------------------------
410
411 {- The entry conventions depend on the type of closure being entered,
412 whether or not it has free variables, and whether we're running
413 sequentially or in parallel.
414
415 Closure Node Argument Enter
416 Characteristics Par Req'd Passing Via
417 -------------------------------------------------------------------------------
418 Unknown & no & yes & stack & node
419 Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args)
420 & slow entry (otherwise)
421 Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args)
422 0 arg, no fvs \r,\s & no & no & n/a & direct entry
423 0 arg, no fvs \u & no & yes & n/a & node
424 0 arg, fvs \r,\s & no & yes & n/a & direct entry
425 0 arg, fvs \u & no & yes & n/a & node
426
427 Unknown & yes & yes & stack & node
428 Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args)
429 & slow entry (otherwise)
430 Known fun (>1 arg), fvs & yes & yes & registers & node
431 0 arg, no fvs \r,\s & yes & no & n/a & direct entry
432 0 arg, no fvs \u & yes & yes & n/a & node
433 0 arg, fvs \r,\s & yes & yes & n/a & node
434 0 arg, fvs \u & yes & yes & n/a & node
435 \end{tabular}
436
437 When black-holing, single-entry closures could also be entered via node
438 (rather than directly) to catch double-entry. -}
439
440 data CallMethod
441 = EnterIt -- No args, not a function
442
443 | JumpToIt -- A join point
444
445 | ReturnIt -- It's a value (function, unboxed value,
446 -- or constructor), so just return it.
447
448 | SlowCall -- Unknown fun, or known fun with
449 -- too few args.
450
451 | DirectEntry -- Jump directly, with args in regs
452 CLabel -- The code label
453 Int -- Its arity
454
455 getCallMethod :: DynFlags
456 -> Name -- Function being applied
457 -> CafInfo -- Can it refer to CAF's?
458 -> LambdaFormInfo -- Its info
459 -> Int -- Number of available arguments
460 -> CallMethod
461
462 getCallMethod _ _name _ lf_info _n_args
463 | nodeMustPointToIt lf_info && opt_Parallel
464 = -- If we're parallel, then we must always enter via node.
465 -- The reason is that the closure may have been
466 -- fetched since we allocated it.
467 EnterIt
468
469 getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
470 | n_args == 0 = ASSERT( arity /= 0 )
471 ReturnIt -- No args at all
472 | n_args < arity = SlowCall -- Not enough args
473 | otherwise = DirectEntry (enterIdLabel name caf) arity
474
475 getCallMethod _ _name _ LFUnLifted n_args
476 = ASSERT( n_args == 0 ) ReturnIt
477
478 getCallMethod _ _name _ (LFCon _) n_args
479 = ASSERT( n_args == 0 ) ReturnIt
480
481 getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
482 | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
483 = SlowCall -- We cannot just enter it [in eval/apply, the entry code
484 -- is the fast-entry code]
485
486 -- Since is_fun is False, we are *definitely* looking at a data value
487 | updatable || doingTickyProfiling dflags -- to catch double entry
488 {- OLD: || opt_SMP
489 I decided to remove this, because in SMP mode it doesn't matter
490 if we enter the same thunk multiple times, so the optimisation
491 of jumping directly to the entry code is still valid. --SDM
492 -}
493 = EnterIt
494 -- We used to have ASSERT( n_args == 0 ), but actually it is
495 -- possible for the optimiser to generate
496 -- let bot :: Int = error Int "urk"
497 -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
498 -- This happens as a result of the case-of-error transformation
499 -- So the right thing to do is just to enter the thing
500
501 | otherwise -- Jump direct to code for single-entry thunks
502 = ASSERT( n_args == 0 )
503 DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
504
505 getCallMethod _ _name _ (LFUnknown True) _n_args
506 = SlowCall -- might be a function
507
508 getCallMethod _ name _ (LFUnknown False) n_args
509 = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
510 EnterIt -- Not a function
511
512 getCallMethod _ _name _ LFBlackHole _n_args
513 = SlowCall -- Presumably the black hole has by now
514 -- been updated, but we don't know with
515 -- what, so we slow call it
516
517 getCallMethod _ _name _ LFLetNoEscape _n_args
518 = JumpToIt
519
520 isKnownFun :: LambdaFormInfo -> Bool
521 isKnownFun (LFReEntrant _ _ _ _) = True
522 isKnownFun LFLetNoEscape = True
523 isKnownFun _ = False
524
525 -----------------------------------------------------------------------------
526 -- staticClosureRequired
527 -----------------------------------------------------------------------------
528
529 {- staticClosureRequired is never called (hence commented out)
530
531 SimonMar writes (Sept 07) It's an optimisation we used to apply at
532 one time, I believe, but it got lost probably in the rewrite of
533 the RTS/code generator. I left that code there to remind me to
534 look into whether it was worth doing sometime
535
536 {- Avoiding generating entries and info tables
537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538 At present, for every function we generate all of the following,
539 just in case. But they aren't always all needed, as noted below:
540
541 [NB1: all of this applies only to *functions*. Thunks always
542 have closure, info table, and entry code.]
543
544 [NB2: All are needed if the function is *exported*, just to play safe.]
545
546 * Fast-entry code ALWAYS NEEDED
547
548 * Slow-entry code
549 Needed iff (a) we have any un-saturated calls to the function
550 OR (b) the function is passed as an arg
551 OR (c) we're in the parallel world and the function has free vars
552 [Reason: in parallel world, we always enter functions
553 with free vars via the closure.]
554
555 * The function closure
556 Needed iff (a) we have any un-saturated calls to the function
557 OR (b) the function is passed as an arg
558 OR (c) if the function has free vars (ie not top level)
559
560 Why case (a) here? Because if the arg-satis check fails,
561 UpdatePAP stuffs a pointer to the function closure in the PAP.
562 [Could be changed; UpdatePAP could stuff in a code ptr instead,
563 but doesn't seem worth it.]
564
565 [NB: these conditions imply that we might need the closure
566 without the slow-entry code. Here's how.
567
568 f x y = let g w = ...x..y..w...
569 in
570 ...(g t)...
571
572 Here we need a closure for g which contains x and y,
573 but since the calls are all saturated we just jump to the
574 fast entry point for g, with R1 pointing to the closure for g.]
575
576
577 * Standard info table
578 Needed iff (a) we have any un-saturated calls to the function
579 OR (b) the function is passed as an arg
580 OR (c) the function has free vars (ie not top level)
581
582 NB. In the sequential world, (c) is only required so that the function closure has
583 an info table to point to, to keep the storage manager happy.
584 If (c) alone is true we could fake up an info table by choosing
585 one of a standard family of info tables, whose entry code just
586 bombs out.
587
588 [NB In the parallel world (c) is needed regardless because
589 we enter functions with free vars via the closure.]
590
591 If (c) is retained, then we'll sometimes generate an info table
592 (for storage mgr purposes) without slow-entry code. Then we need
593 to use an error label in the info table to substitute for the absent
594 slow entry code.
595 -}
596
597 staticClosureRequired
598 :: Name
599 -> StgBinderInfo
600 -> LambdaFormInfo
601 -> Bool
602 staticClosureRequired binder bndr_info
603 (LFReEntrant top_level _ _ _) -- It's a function
604 = ASSERT( isTopLevel top_level )
605 -- Assumption: it's a top-level, no-free-var binding
606 not (satCallsOnly bndr_info)
607
608 staticClosureRequired binder other_binder_info other_lf_info = True
609 -}
610
611 -----------------------------------------------------------------------------
612 -- Data types for closure information
613 -----------------------------------------------------------------------------
614
615
616 {- ClosureInfo: information about a binding
617
618 We make a ClosureInfo for each let binding (both top level and not),
619 but not bindings for data constructors: for those we build a CmmInfoTable
620 directly (see mkDataConInfoTable).
621
622 To a first approximation:
623 ClosureInfo = (LambdaFormInfo, CmmInfoTable)
624
625 A ClosureInfo has enough information
626 a) to construct the info table itself, and build other things
627 related to the binding (e.g. slow entry points for a function)
628 b) to allocate a closure containing that info pointer (i.e.
629 it knows the info table label)
630 -}
631
632 data ClosureInfo
633 = ClosureInfo {
634 closureName :: !Name, -- The thing bound to this closure
635 -- we don't really need this field: it's only used in generating
636 -- code for ticky and profiling, and we could pass the information
637 -- around separately, but it doesn't do much harm to keep it here.
638
639 closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
640 -- this tells us about what the closure contains: it's right-hand-side.
641
642 -- the rest is just an unpacked CmmInfoTable.
643 closureInfoLabel :: !CLabel,
644 closureSMRep :: !SMRep, -- representation used by storage mgr
645 closureSRT :: !C_SRT, -- What SRT applies to this closure
646 closureProf :: !ProfilingInfo
647 }
648
649 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
650 mkCmmInfo :: ClosureInfo -> CmmInfoTable
651 mkCmmInfo ClosureInfo {..}
652 = CmmInfoTable { cit_lbl = closureInfoLabel
653 , cit_rep = closureSMRep
654 , cit_prof = closureProf
655 , cit_srt = closureSRT }
656
657
658 --------------------------------------
659 -- Building ClosureInfos
660 --------------------------------------
661
662 mkClosureInfo :: Bool -- Is static
663 -> Id
664 -> LambdaFormInfo
665 -> Int -> Int -- Total and pointer words
666 -> C_SRT
667 -> String -- String descriptor
668 -> ClosureInfo
669 mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info val_descr
670 = ClosureInfo { closureName = name,
671 closureLFInfo = lf_info,
672 closureInfoLabel = info_lbl,
673 closureSMRep = sm_rep, -- These four fields are a
674 closureSRT = srt_info, -- CmmInfoTable
675 closureProf = prof } -- ---
676 where
677 name = idName id
678 sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
679 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 -- Eager blackholing is normally disabled, but can be turned on with
689 -- -feager-blackholing. When it is on, we replace the info pointer of
690 -- the thunk with stg_EAGER_BLACKHOLE_info on entry.
691
692 -- If we wanted to do eager blackholing with slop filling,
693 -- we'd need to do it at the *end* of a basic block, otherwise
694 -- we overwrite the free variables in the thunk that we still
695 -- need. We have a patch for this from Andy Cheadle, but not
696 -- incorporated yet. --SDM [6/2004]
697 --
698 --
699 -- Previously, eager blackholing was enabled when ticky-ticky
700 -- was on. But it didn't work, and it wasn't strictly necessary
701 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
702 -- is unconditionally disabled. -- krc 1/2007
703
704 -- Static closures are never themselves black-holed.
705
706 blackHoleOnEntry :: ClosureInfo -> Bool
707 blackHoleOnEntry cl_info
708 | isStaticRep (closureSMRep cl_info)
709 = False -- Never black-hole a static closure
710
711 | otherwise
712 = case closureLFInfo cl_info of
713 LFReEntrant _ _ _ _ -> False
714 LFLetNoEscape -> False
715 LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks.
716 _other -> panic "blackHoleOnEntry" -- Should never happen
717
718 isStaticClosure :: ClosureInfo -> Bool
719 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
720
721 closureUpdReqd :: ClosureInfo -> Bool
722 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
723
724 lfUpdatable :: LambdaFormInfo -> Bool
725 lfUpdatable (LFThunk _ _ upd _ _) = upd
726 lfUpdatable LFBlackHole = True
727 -- Black-hole closures are allocated to receive the results of an
728 -- alg case with a named default... so they need to be updated.
729 lfUpdatable _ = False
730
731 closureSingleEntry :: ClosureInfo -> Bool
732 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
733 closureSingleEntry _ = False
734
735 closureReEntrant :: ClosureInfo -> Bool
736 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
737 closureReEntrant _ = False
738
739 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
740 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
741
742 lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
743 lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
744 lfFunInfo _ = Nothing
745
746 funTag :: ClosureInfo -> DynTag
747 funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
748
749 isToplevClosure :: ClosureInfo -> Bool
750 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
751 = case lf_info of
752 LFReEntrant TopLevel _ _ _ -> True
753 LFThunk TopLevel _ _ _ _ -> True
754 _other -> False
755
756 --------------------------------------
757 -- Label generation
758 --------------------------------------
759
760 staticClosureLabel :: ClosureInfo -> CLabel
761 staticClosureLabel = toClosureLbl . closureInfoLabel
762
763 closureRednCountsLabel :: ClosureInfo -> CLabel
764 closureRednCountsLabel = toRednCountsLbl . closureInfoLabel
765
766 closureSlowEntryLabel :: ClosureInfo -> CLabel
767 closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
768
769 closureLocalEntryLabel :: ClosureInfo -> CLabel
770 closureLocalEntryLabel
771 | tablesNextToCode = toInfoLbl . closureInfoLabel
772 | otherwise = toEntryLbl . closureInfoLabel
773
774 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
775 mkClosureInfoTableLabel id lf_info
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 LFThunk{} -> std_mk_lbl name cafs
786 LFReEntrant{} -> std_mk_lbl name cafs
787 _other -> panic "closureInfoTableLabel"
788
789 where
790 name = idName id
791
792 std_mk_lbl | is_local = mkLocalInfoTableLabel
793 | otherwise = mkInfoTableLabel
794
795 cafs = idCafInfo id
796 is_local = isDataConWorkId id
797 -- Make the _info pointer for the implicit datacon worker
798 -- binding local. The reason we can do this is that importing
799 -- code always either uses the _closure or _con_info. By the
800 -- invariants in CorePrep anything else gets eta expanded.
801
802
803 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
804 -- thunkEntryLabel is a local help function, not exported. It's used from
805 -- getCallMethod.
806 thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
807 = enterApLabel upd_flag arity
808 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
809 = enterSelectorLabel upd_flag offset
810 thunkEntryLabel thunk_id c _ _
811 = enterIdLabel thunk_id c
812
813 enterApLabel :: Bool -> Arity -> CLabel
814 enterApLabel is_updatable arity
815 | tablesNextToCode = mkApInfoTableLabel is_updatable arity
816 | otherwise = mkApEntryLabel is_updatable arity
817
818 enterSelectorLabel :: Bool -> WordOff -> CLabel
819 enterSelectorLabel upd_flag offset
820 | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
821 | otherwise = mkSelectorEntryLabel upd_flag offset
822
823 enterIdLabel :: Name -> CafInfo -> CLabel
824 enterIdLabel id c
825 | tablesNextToCode = mkInfoTableLabel id c
826 | otherwise = mkEntryLabel id c
827
828
829 --------------------------------------
830 -- Profiling
831 --------------------------------------
832
833 -- Profiling requires two pieces of information to be determined for
834 -- each closure's info table --- description and type.
835
836 -- The description is stored directly in the @CClosureInfoTable@ when the
837 -- info table is built.
838
839 -- The type is determined from the type information stored with the @Id@
840 -- in the closure info using @closureTypeDescr@.
841
842 mkProfilingInfo :: Id -> String -> ProfilingInfo
843 mkProfilingInfo id val_descr
844 | not opt_SccProfilingOn = NoProfilingInfo
845 | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
846 where
847 ty_descr_w8 = stringToWord8s (getTyDescription (idType id))
848 val_descr_w8 = stringToWord8s val_descr
849
850 getTyDescription :: Type -> String
851 getTyDescription ty
852 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
853 case tau_ty of
854 TyVarTy _ -> "*"
855 AppTy fun _ -> getTyDescription fun
856 FunTy _ res -> '-' : '>' : fun_result res
857 TyConApp tycon _ -> getOccString tycon
858 PredTy sty -> getPredTyDescription sty
859 ForAllTy _ ty -> getTyDescription ty
860 }
861 where
862 fun_result (FunTy _ res) = '>' : fun_result res
863 fun_result other = getTyDescription other
864
865 getPredTyDescription :: PredType -> String
866 getPredTyDescription (ClassP cl _) = getOccString cl
867 getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
868 getPredTyDescription (EqPred {}) = "Type equality"
869
870 --------------------------------------
871 -- CmmInfoTable-related things
872 --------------------------------------
873
874 mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable
875 mkDataConInfoTable data_con is_static ptr_wds nonptr_wds
876 = CmmInfoTable { cit_lbl = info_lbl
877 , cit_rep = sm_rep
878 , cit_prof = prof
879 , cit_srt = NoC_SRT }
880 where
881 name = dataConName data_con
882
883 info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs
884 | otherwise = mkConInfoTableLabel name NoCafRefs
885
886 sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type
887
888 cl_type = Constr (fromIntegral (dataConTagZ data_con))
889 (dataConIdentity data_con)
890
891 prof | not opt_SccProfilingOn = NoProfilingInfo
892 | otherwise = ProfilingInfo ty_descr val_descr
893
894 ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
895 val_descr = stringToWord8s $ occNameString $ getOccName data_con
896
897 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
898 -- want to allocate the black hole on entry to a CAF.
899
900 cafBlackHoleInfoTable :: CmmInfoTable
901 cafBlackHoleInfoTable
902 = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel
903 , cit_rep = blackHoleRep
904 , cit_prof = NoProfilingInfo
905 , cit_srt = NoC_SRT }
906
907 staticClosureNeedsLink :: CmmInfoTable -> Bool
908 -- A static closure needs a link field to aid the GC when traversing
909 -- the static closure graph. But it only needs such a field if either
910 -- a) it has an SRT
911 -- b) it's a constructor with one or more pointer fields
912 -- In case (b), the constructor's fields themselves play the role
913 -- of the SRT.
914 staticClosureNeedsLink info_tbl@CmmInfoTable{ cit_rep = smrep }
915 | isConRep smrep = not (isStaticNoCafCon smrep)
916 | otherwise = needsSRT (cit_srt info_tbl)
917 staticClosureNeedsLink _ = False
918