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