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