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