300606eb7edc54c00157ac30991ccb6988ee8204
[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 :: DynFlags -> ClosureInfo -> Bool
707 blackHoleOnEntry dflags 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 _ _
716 | eager_blackholing -> doingTickyProfiling dflags || not no_fvs
717 -- the former to catch double entry,
718 -- and the latter to plug space-leaks. KSW/SDM 1999-04.
719 | otherwise -> False
720
721 where eager_blackholing = not opt_SccProfilingOn
722 && dopt Opt_EagerBlackHoling dflags
723 -- Profiling needs slop filling (to support
724 -- LDV profiling), so currently eager
725 -- blackholing doesn't work with profiling.
726
727 _other -> panic "blackHoleOnEntry" -- Should never happen
728
729 isStaticClosure :: ClosureInfo -> Bool
730 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
731
732 closureUpdReqd :: ClosureInfo -> Bool
733 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
734
735 lfUpdatable :: LambdaFormInfo -> Bool
736 lfUpdatable (LFThunk _ _ upd _ _) = upd
737 lfUpdatable LFBlackHole = True
738 -- Black-hole closures are allocated to receive the results of an
739 -- alg case with a named default... so they need to be updated.
740 lfUpdatable _ = False
741
742 closureSingleEntry :: ClosureInfo -> Bool
743 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
744 closureSingleEntry _ = False
745
746 closureReEntrant :: ClosureInfo -> Bool
747 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
748 closureReEntrant _ = False
749
750 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
751 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
752
753 lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
754 lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
755 lfFunInfo _ = Nothing
756
757 funTag :: ClosureInfo -> DynTag
758 funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
759
760 isToplevClosure :: ClosureInfo -> Bool
761 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
762 = case lf_info of
763 LFReEntrant TopLevel _ _ _ -> True
764 LFThunk TopLevel _ _ _ _ -> True
765 _other -> False
766
767 --------------------------------------
768 -- Label generation
769 --------------------------------------
770
771 staticClosureLabel :: ClosureInfo -> CLabel
772 staticClosureLabel = toClosureLbl . closureInfoLabel
773
774 closureRednCountsLabel :: ClosureInfo -> CLabel
775 closureRednCountsLabel = toRednCountsLbl . closureInfoLabel
776
777 closureSlowEntryLabel :: ClosureInfo -> CLabel
778 closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
779
780 closureLocalEntryLabel :: ClosureInfo -> CLabel
781 closureLocalEntryLabel
782 | tablesNextToCode = toInfoLbl . closureInfoLabel
783 | otherwise = toEntryLbl . closureInfoLabel
784
785 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
786 mkClosureInfoTableLabel id lf_info
787 = case lf_info of
788 LFBlackHole -> mkCAFBlackHoleInfoTableLabel
789
790 LFThunk _ _ upd_flag (SelectorThunk offset) _
791 -> mkSelectorInfoLabel upd_flag offset
792
793 LFThunk _ _ upd_flag (ApThunk arity) _
794 -> mkApInfoTableLabel upd_flag arity
795
796 LFThunk{} -> std_mk_lbl name cafs
797 LFReEntrant{} -> std_mk_lbl name cafs
798 _other -> panic "closureInfoTableLabel"
799
800 where
801 name = idName id
802
803 std_mk_lbl | is_local = mkLocalInfoTableLabel
804 | otherwise = mkInfoTableLabel
805
806 cafs = idCafInfo id
807 is_local = isDataConWorkId id
808 -- Make the _info pointer for the implicit datacon worker
809 -- binding local. The reason we can do this is that importing
810 -- code always either uses the _closure or _con_info. By the
811 -- invariants in CorePrep anything else gets eta expanded.
812
813
814 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
815 -- thunkEntryLabel is a local help function, not exported. It's used from
816 -- getCallMethod.
817 thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
818 = enterApLabel upd_flag arity
819 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
820 = enterSelectorLabel upd_flag offset
821 thunkEntryLabel thunk_id c _ _
822 = enterIdLabel thunk_id c
823
824 enterApLabel :: Bool -> Arity -> CLabel
825 enterApLabel is_updatable arity
826 | tablesNextToCode = mkApInfoTableLabel is_updatable arity
827 | otherwise = mkApEntryLabel is_updatable arity
828
829 enterSelectorLabel :: Bool -> WordOff -> CLabel
830 enterSelectorLabel upd_flag offset
831 | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
832 | otherwise = mkSelectorEntryLabel upd_flag offset
833
834 enterIdLabel :: Name -> CafInfo -> CLabel
835 enterIdLabel id c
836 | tablesNextToCode = mkInfoTableLabel id c
837 | otherwise = mkEntryLabel id c
838
839
840 --------------------------------------
841 -- Profiling
842 --------------------------------------
843
844 -- Profiling requires two pieces of information to be determined for
845 -- each closure's info table --- description and type.
846
847 -- The description is stored directly in the @CClosureInfoTable@ when the
848 -- info table is built.
849
850 -- The type is determined from the type information stored with the @Id@
851 -- in the closure info using @closureTypeDescr@.
852
853 mkProfilingInfo :: Id -> String -> ProfilingInfo
854 mkProfilingInfo id val_descr
855 | not opt_SccProfilingOn = NoProfilingInfo
856 | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
857 where
858 ty_descr_w8 = stringToWord8s (getTyDescription (idType id))
859 val_descr_w8 = stringToWord8s val_descr
860
861 getTyDescription :: Type -> String
862 getTyDescription ty
863 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
864 case tau_ty of
865 TyVarTy _ -> "*"
866 AppTy fun _ -> getTyDescription fun
867 FunTy _ res -> '-' : '>' : fun_result res
868 TyConApp tycon _ -> getOccString tycon
869 PredTy sty -> getPredTyDescription sty
870 ForAllTy _ ty -> getTyDescription ty
871 }
872 where
873 fun_result (FunTy _ res) = '>' : fun_result res
874 fun_result other = getTyDescription other
875
876 getPredTyDescription :: PredType -> String
877 getPredTyDescription (ClassP cl _) = getOccString cl
878 getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
879 getPredTyDescription (EqPred {}) = "Type equality"
880
881 --------------------------------------
882 -- CmmInfoTable-related things
883 --------------------------------------
884
885 mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable
886 mkDataConInfoTable data_con is_static ptr_wds nonptr_wds
887 = CmmInfoTable { cit_lbl = info_lbl
888 , cit_rep = sm_rep
889 , cit_prof = prof
890 , cit_srt = NoC_SRT }
891 where
892 name = dataConName data_con
893
894 info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs
895 | otherwise = mkConInfoTableLabel name NoCafRefs
896
897 sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type
898
899 cl_type = Constr (fromIntegral (dataConTagZ data_con))
900 (dataConIdentity data_con)
901
902 prof | not opt_SccProfilingOn = NoProfilingInfo
903 | otherwise = ProfilingInfo ty_descr val_descr
904
905 ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
906 val_descr = stringToWord8s $ occNameString $ getOccName data_con
907
908 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
909 -- want to allocate the black hole on entry to a CAF.
910
911 cafBlackHoleInfoTable :: CmmInfoTable
912 cafBlackHoleInfoTable
913 = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel
914 , cit_rep = blackHoleRep
915 , cit_prof = NoProfilingInfo
916 , cit_srt = NoC_SRT }
917
918 staticClosureNeedsLink :: CmmInfoTable -> Bool
919 -- A static closure needs a link field to aid the GC when traversing
920 -- the static closure graph. But it only needs such a field if either
921 -- a) it has an SRT
922 -- b) it's a constructor with one or more pointer fields
923 -- In case (b), the constructor's fields themselves play the role
924 -- of the SRT.
925 staticClosureNeedsLink info_tbl@CmmInfoTable{ cit_rep = smrep }
926 | isConRep smrep = not (isStaticNoCafCon smrep)
927 | otherwise = needsSRT (cit_srt info_tbl)
928 staticClosureNeedsLink _ = False
929