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