1 -----------------------------------------------------------------------------
3 -- Stg to C-- code generation:
5 -- The types LambdaFormInfo
8 -- Nothing monadic in here!
10 -- (c) The University of Glasgow 2004-2006
12 -----------------------------------------------------------------------------
14 module StgCmmClosure (
16 DynTag, tagForCon, isSmallFamily,
19 ArgDescr(..), Liveness(..),
22 isVoidRep, isGcPtrRep, addIdReps, addArgReps,
25 LambdaFormInfo, -- Abstract
26 StandardFormInfo, -- ...ditto...
27 mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
28 mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
32 mkClosureInfo, mkConInfo, maybeIsLFCon,
34 closureSize, closureNonHdrSize,
35 closureGoodStuffSize, closurePtrsSize,
38 closureName, infoTableLabelFromCI,
41 closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
42 closureNeedsUpdSpace, closureIsThunk,
43 closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
44 closureFunInfo, isStandardFormThunk, isKnownFun,
47 enterIdLabel, enterLocalIdLabel,
50 CallMethod(..), getCallMethod,
57 closureValDescr, closureTypeDescr, -- profiling
60 cafBlackHoleClosureInfo,
62 staticClosureNeedsLink, clHasCafRefs
65 #include "../includes/MachDeps.h"
67 #define FAST_STRING_NOT_NEEDED
68 #include "HsVersions.h"
70 import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
71 -- XXX temporary becuase FunInfo needs this one
75 import CmmDecl ( ClosureTypeInfo(..), ConstrDescription )
93 -----------------------------------------------------------------------------
95 -----------------------------------------------------------------------------
97 addIdReps :: [Id] -> [(PrimRep, Id)]
98 addIdReps ids = [(idPrimRep id, id) | id <- ids]
100 addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
101 addArgReps args = [(argPrimRep arg, arg) | arg <- args]
103 argPrimRep :: StgArg -> PrimRep
104 argPrimRep arg = typePrimRep (stgArgType arg)
106 isVoidRep :: PrimRep -> Bool
107 isVoidRep VoidRep = True
108 isVoidRep _other = False
110 isGcPtrRep :: PrimRep -> Bool
111 isGcPtrRep PtrRep = True
115 -----------------------------------------------------------------------------
117 -----------------------------------------------------------------------------
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.
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)
131 | LFThunk -- Thunk (zero arity)
133 !Bool -- True <=> no free vars
134 !Bool -- True <=> updatable (i.e., *not* single-entry)
136 !Bool -- True <=> *might* be a function type
138 | LFCon -- A saturated constructor application
139 DataCon -- The constructor
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
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
152 | LFUnLifted -- A value of unboxed type;
153 -- always a value, neeeds evaluation
155 | LFLetNoEscape -- See LetNoEscape module for precise description
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 CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
163 -------------------------
164 -- An ArgDsecr describes the argument pattern of a function
166 {- XXX -- imported from old ClosureInfo for now
168 = ArgSpec -- Fits one of the standard patterns
169 !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ...
171 | ArgGen -- General case
172 Liveness -- Details about the arguments
175 {- XXX -- imported from old ClosureInfo for now
176 -------------------------
177 -- We represent liveness bitmaps as a Bitmap (whose internal
178 -- representation really is a bitmap). These are pinned onto case return
179 -- vectors to indicate the state of the stack for the garbage collector.
181 -- In the compiled program, liveness bitmaps that fit inside a single
182 -- word (StgWord) are stored as a single word, while larger bitmaps are
183 -- stored as a pointer to an array of words.
186 = SmallLiveness -- Liveness info that fits in one word
187 StgWord -- Here's the bitmap
189 | BigLiveness -- Liveness info witha a multi-word bitmap
190 CLabel -- Label for the bitmap
193 -------------------------
194 -- StandardFormInfo tells whether this thunk has one of
195 -- a small number of standard forms
197 data StandardFormInfo
199 -- Not of of the standard forms
202 -- A SelectorThunk is of form
204 -- con a1,..,an -> ak
205 -- and the constructor is from a single-constr type.
206 WordOff -- 0-origin offset of ak within the "goods" of
207 -- constructor (Recall that the a1,...,an may be laid
208 -- out in the heap in a non-obvious order.)
211 -- An ApThunk is of form
213 -- The code for the thunk just pushes x2..xn on the stack and enters x1.
214 -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
215 -- in the RTS to save space.
219 ------------------------------------------------------
220 -- Building LambdaFormInfo
221 ------------------------------------------------------
223 mkLFArgument :: Id -> LambdaFormInfo
225 | isUnLiftedType ty = LFUnLifted
226 | might_be_a_function ty = LFUnknown True
227 | otherwise = LFUnknown False
232 mkLFLetNoEscape :: LambdaFormInfo
233 mkLFLetNoEscape = LFLetNoEscape
236 mkLFReEntrant :: TopLevelFlag -- True of top level
239 -> ArgDescr -- Argument descriptor
242 mkLFReEntrant top fvs args arg_descr
243 = LFReEntrant top (length args) (null fvs) arg_descr
246 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
247 mkLFThunk thunk_ty top fvs upd_flag
248 = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
249 LFThunk top (null fvs)
250 (isUpdatable upd_flag)
252 (might_be_a_function thunk_ty)
255 might_be_a_function :: Type -> Bool
256 -- Return False only if we are *sure* it's a data type
257 -- Look through newtypes etc as much as poss
258 might_be_a_function ty
259 = case splitTyConApp_maybe (repType ty) of
260 Just (tc, _) -> not (isDataTyCon tc)
264 mkConLFInfo :: DataCon -> LambdaFormInfo
265 mkConLFInfo con = LFCon con
268 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
269 mkSelectorLFInfo id offset updatable
270 = LFThunk NotTopLevel False updatable (SelectorThunk offset)
271 (might_be_a_function (idType id))
274 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
275 mkApLFInfo id upd_flag arity
276 = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
277 (might_be_a_function (idType id))
280 mkLFImported :: Id -> LambdaFormInfo
282 | Just con <- isDataConWorkId_maybe id
283 , isNullaryRepDataCon con
284 = LFCon con -- An imported nullary constructor
285 -- We assume that the constructor is evaluated so that
286 -- the id really does point directly to the constructor
289 = LFReEntrant TopLevel arity True (panic "arg_descr")
292 = mkLFArgument id -- Not sure of exact arity
296 -----------------------------------------------------
297 -- Dynamic pointer tagging
298 -----------------------------------------------------
300 type ConTagZ = Int -- A *zero-indexed* contructor tag
302 type DynTag = Int -- The tag on a *pointer*
303 -- (from the dynamic-tagging paper)
305 {- Note [Data constructor dynamic tags]
306 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307 The family size of a data type (the number of constructors)
309 * small, if the family size < 2**tag_bits
312 Small families can have the constructor tag in the tag bits.
313 Big families only use the tag value 1 to represent evaluatedness. -}
315 isSmallFamily :: Int -> Bool
316 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
318 -- We keep the *zero-indexed* tag in the srt_len field of the info
319 -- table of a data constructor.
320 dataConTagZ :: DataCon -> ConTagZ
321 dataConTagZ con = dataConTag con - fIRST_TAG
323 tagForCon :: DataCon -> DynTag
325 | isSmallFamily fam_size = con_tag + 1
328 con_tag = dataConTagZ con
329 fam_size = tyConFamilySize (dataConTyCon con)
331 tagForArity :: Int -> DynTag
332 tagForArity arity | isSmallFamily arity = arity
335 lfDynTag :: LambdaFormInfo -> DynTag
336 -- Return the tag in the low order bits of a variable bound
337 -- to this LambdaForm
338 lfDynTag (LFCon con) = tagForCon con
339 lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
343 -----------------------------------------------------------------------------
344 -- Observing LambdaFormInfo
345 -----------------------------------------------------------------------------
348 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
349 maybeIsLFCon (LFCon con) = Just con
350 maybeIsLFCon _ = Nothing
353 isLFThunk :: LambdaFormInfo -> Bool
354 isLFThunk (LFThunk _ _ _ _ _) = True
355 isLFThunk (LFBlackHole _) = True
356 -- return True for a blackhole: this function is used to determine
357 -- whether to use the thunk header in SMP mode, and a blackhole
362 -----------------------------------------------------------------------------
364 -----------------------------------------------------------------------------
367 :: Bool -- True <=> static closure
369 -> WordOff -> WordOff -- Tot wds, ptr wds
372 chooseSMRep is_static lf_info tot_wds ptr_wds
374 nonptr_wds = tot_wds - ptr_wds
375 closure_type = getClosureType is_static ptr_wds lf_info
377 GenericRep is_static ptr_wds nonptr_wds closure_type
379 -- We *do* get non-updatable top-level thunks sometimes. eg. f = g
380 -- gets compiled to a jump to g (if g has non-zero arity), instead of
381 -- messing around with update frames and PAPs. We set the closure type
382 -- to FUN_STATIC in this case.
384 getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
385 getClosureType is_static ptr_wds lf_info
387 LFCon {} | is_static && ptr_wds == 0 -> ConstrNoCaf
388 | otherwise -> Constr
389 LFReEntrant {} -> Fun
390 LFThunk _ _ _ (SelectorThunk {}) _ -> ThunkSelector
392 _ -> panic "getClosureType"
395 -----------------------------------------------------------------------------
397 -----------------------------------------------------------------------------
399 -- Be sure to see the stg-details notes about these...
401 nodeMustPointToIt :: LambdaFormInfo -> Bool
402 nodeMustPointToIt (LFReEntrant top _ no_fvs _)
403 = not no_fvs || -- Certainly if it has fvs we need to point to it
405 -- If it is not top level we will point to it
406 -- We can have a \r closure with no_fvs which
407 -- is not top level as special case cgRhsClosure
408 -- has been dissabled in favour of let floating
410 -- For lex_profiling we also access the cost centre for a
411 -- non-inherited function i.e. not top level
412 -- the not top case above ensures this is ok.
414 nodeMustPointToIt (LFCon _) = True
416 -- Strictly speaking, the above two don't need Node to point
417 -- to it if the arity = 0. But this is a *really* unlikely
418 -- situation. If we know it's nil (say) and we are entering
419 -- it. Eg: let x = [] in x then we will certainly have inlined
420 -- x, since nil is a simple atom. So we gain little by not
421 -- having Node point to known zero-arity things. On the other
422 -- hand, we do lose something; Patrick's code for figuring out
423 -- when something has been updated but not entered relies on
424 -- having Node point to the result of an update. SLPJ
427 nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
428 = updatable || not no_fvs || opt_SccProfilingOn
429 -- For the non-updatable (single-entry case):
431 -- True if has fvs (in which case we need access to them, and we
432 -- should black-hole it)
433 -- or profiling (in which case we need to recover the cost centre
436 nodeMustPointToIt (LFThunk {}) -- Node must point to a standard-form thunk
439 nodeMustPointToIt (LFUnknown _) = True
440 nodeMustPointToIt LFUnLifted = False
441 nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point
442 nodeMustPointToIt LFLetNoEscape = False
444 -----------------------------------------------------------------------------
446 -----------------------------------------------------------------------------
448 {- The entry conventions depend on the type of closure being entered,
449 whether or not it has free variables, and whether we're running
450 sequentially or in parallel.
452 Closure Node Argument Enter
453 Characteristics Par Req'd Passing Via
454 -------------------------------------------------------------------------------
455 Unknown & no & yes & stack & node
456 Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args)
457 & slow entry (otherwise)
458 Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args)
459 0 arg, no fvs \r,\s & no & no & n/a & direct entry
460 0 arg, no fvs \u & no & yes & n/a & node
461 0 arg, fvs \r,\s & no & yes & n/a & direct entry
462 0 arg, fvs \u & no & yes & n/a & node
464 Unknown & yes & yes & stack & node
465 Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args)
466 & slow entry (otherwise)
467 Known fun (>1 arg), fvs & yes & yes & registers & node
468 0 arg, no fvs \r,\s & yes & no & n/a & direct entry
469 0 arg, no fvs \u & yes & yes & n/a & node
470 0 arg, fvs \r,\s & yes & yes & n/a & node
471 0 arg, fvs \u & yes & yes & n/a & node
474 When black-holing, single-entry closures could also be entered via node
475 (rather than directly) to catch double-entry. -}
478 = EnterIt -- No args, not a function
480 | JumpToIt -- A join point
482 | ReturnIt -- It's a value (function, unboxed value,
483 -- or constructor), so just return it.
485 | SlowCall -- Unknown fun, or known fun with
488 | DirectEntry -- Jump directly, with args in regs
489 CLabel -- The code label
492 getCallMethod :: DynFlags
493 -> Name -- Function being applied
494 -> CafInfo -- Can it refer to CAF's?
495 -> LambdaFormInfo -- Its info
496 -> Int -- Number of available arguments
499 getCallMethod _ _name _ lf_info _n_args
500 | nodeMustPointToIt lf_info && opt_Parallel
501 = -- If we're parallel, then we must always enter via node.
502 -- The reason is that the closure may have been
503 -- fetched since we allocated it.
506 getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
507 | n_args == 0 = ASSERT( arity /= 0 )
508 ReturnIt -- No args at all
509 | n_args < arity = SlowCall -- Not enough args
510 | otherwise = DirectEntry (enterIdLabel name caf) arity
512 getCallMethod _ _name _ LFUnLifted n_args
513 = ASSERT( n_args == 0 ) ReturnIt
515 getCallMethod _ _name _ (LFCon _) n_args
516 = ASSERT( n_args == 0 ) ReturnIt
518 getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
519 | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
520 = SlowCall -- We cannot just enter it [in eval/apply, the entry code
521 -- is the fast-entry code]
523 -- Since is_fun is False, we are *definitely* looking at a data value
524 | updatable || doingTickyProfiling dflags -- to catch double entry
526 I decided to remove this, because in SMP mode it doesn't matter
527 if we enter the same thunk multiple times, so the optimisation
528 of jumping directly to the entry code is still valid. --SDM
531 -- We used to have ASSERT( n_args == 0 ), but actually it is
532 -- possible for the optimiser to generate
533 -- let bot :: Int = error Int "urk"
534 -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
535 -- This happens as a result of the case-of-error transformation
536 -- So the right thing to do is just to enter the thing
538 | otherwise -- Jump direct to code for single-entry thunks
539 = ASSERT( n_args == 0 )
540 DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
542 getCallMethod _ _name _ (LFUnknown True) _n_args
543 = SlowCall -- might be a function
545 getCallMethod _ name _ (LFUnknown False) n_args
546 = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
547 EnterIt -- Not a function
549 getCallMethod _ _name _ (LFBlackHole _) _n_args
550 = SlowCall -- Presumably the black hole has by now
551 -- been updated, but we don't know with
552 -- what, so we slow call it
554 getCallMethod _ _name _ LFLetNoEscape _n_args
557 isStandardFormThunk :: LambdaFormInfo -> Bool
558 isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
559 isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
560 isStandardFormThunk _other_lf_info = False
562 isKnownFun :: LambdaFormInfo -> Bool
563 isKnownFun (LFReEntrant _ _ _ _) = True
564 isKnownFun LFLetNoEscape = True
567 -----------------------------------------------------------------------------
568 -- staticClosureRequired
569 -----------------------------------------------------------------------------
571 {- staticClosureRequired is never called (hence commented out)
573 SimonMar writes (Sept 07) It's an optimisation we used to apply at
574 one time, I believe, but it got lost probably in the rewrite of
575 the RTS/code generator. I left that code there to remind me to
576 look into whether it was worth doing sometime
578 {- Avoiding generating entries and info tables
579 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
580 At present, for every function we generate all of the following,
581 just in case. But they aren't always all needed, as noted below:
583 [NB1: all of this applies only to *functions*. Thunks always
584 have closure, info table, and entry code.]
586 [NB2: All are needed if the function is *exported*, just to play safe.]
588 * Fast-entry code ALWAYS NEEDED
591 Needed iff (a) we have any un-saturated calls to the function
592 OR (b) the function is passed as an arg
593 OR (c) we're in the parallel world and the function has free vars
594 [Reason: in parallel world, we always enter functions
595 with free vars via the closure.]
597 * The function closure
598 Needed iff (a) we have any un-saturated calls to the function
599 OR (b) the function is passed as an arg
600 OR (c) if the function has free vars (ie not top level)
602 Why case (a) here? Because if the arg-satis check fails,
603 UpdatePAP stuffs a pointer to the function closure in the PAP.
604 [Could be changed; UpdatePAP could stuff in a code ptr instead,
605 but doesn't seem worth it.]
607 [NB: these conditions imply that we might need the closure
608 without the slow-entry code. Here's how.
610 f x y = let g w = ...x..y..w...
614 Here we need a closure for g which contains x and y,
615 but since the calls are all saturated we just jump to the
616 fast entry point for g, with R1 pointing to the closure for g.]
619 * Standard info table
620 Needed iff (a) we have any un-saturated calls to the function
621 OR (b) the function is passed as an arg
622 OR (c) the function has free vars (ie not top level)
624 NB. In the sequential world, (c) is only required so that the function closure has
625 an info table to point to, to keep the storage manager happy.
626 If (c) alone is true we could fake up an info table by choosing
627 one of a standard family of info tables, whose entry code just
630 [NB In the parallel world (c) is needed regardless because
631 we enter functions with free vars via the closure.]
633 If (c) is retained, then we'll sometimes generate an info table
634 (for storage mgr purposes) without slow-entry code. Then we need
635 to use an error label in the info table to substitute for the absent
639 staticClosureRequired
644 staticClosureRequired binder bndr_info
645 (LFReEntrant top_level _ _ _) -- It's a function
646 = ASSERT( isTopLevel top_level )
647 -- Assumption: it's a top-level, no-free-var binding
648 not (satCallsOnly bndr_info)
650 staticClosureRequired binder other_binder_info other_lf_info = True
653 -----------------------------------------------------------------------------
654 -- Data types for closure information}
655 -----------------------------------------------------------------------------
658 {- Information about a closure, from the code generator's point of view.
660 A ClosureInfo decribes the info pointer of a closure. It has
662 a) to construct the info table itself
663 b) to allocate a closure containing that info pointer (i.e.
664 it knows the info table label)
666 We make a ClosureInfo for
667 - each let binding (both top level and not)
668 - each data constructor (for its shared static and
674 closureName :: !Name, -- The thing bound to this closure
675 closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
676 closureSMRep :: !SMRep, -- representation used by storage mgr
677 closureSRT :: !C_SRT, -- What SRT applies to this closure
678 closureType :: !Type, -- Type of closure (ToDo: remove)
679 closureDescr :: !String, -- closure description (for profiling)
680 closureCafs :: !CafInfo -- whether the closure may have CAFs
683 -- Constructor closures don't have a unique info table label (they use
684 -- the constructor's info table), and they don't have an SRT.
686 closureCon :: !DataCon,
687 closureSMRep :: !SMRep
690 {- XXX temp imported from old ClosureInfo
691 -- C_SRT is what StgSyn.SRT gets translated to...
692 -- we add a label for the table, and expect only the 'offset/length' form
695 | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
698 instance Outputable C_SRT where
699 ppr (NoC_SRT) = ptext SLIT("_no_srt_")
700 ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
703 needsSRT :: C_SRT -> Bool
704 needsSRT NoC_SRT = False
705 needsSRT (C_SRT _ _ _) = True
708 --------------------------------------
709 -- Building ClosureInfos
710 --------------------------------------
712 mkClosureInfo :: Bool -- Is static
715 -> Int -> Int -- Total and pointer words
717 -> String -- String descriptor
719 mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
720 = ClosureInfo { closureName = name,
721 closureLFInfo = lf_info,
722 closureSMRep = sm_rep,
723 closureSRT = srt_info,
724 closureType = idType id,
725 closureDescr = descr,
726 closureCafs = idCafInfo id }
729 sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
731 mkConInfo :: Bool -- Is static
733 -> Int -> Int -- Total and pointer words
735 mkConInfo is_static data_con tot_wds ptr_wds
736 = ConInfo { closureSMRep = sm_rep,
737 closureCon = data_con }
739 sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
742 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
743 -- want to allocate the black hole on entry to a CAF. These are the only
744 -- ways to build an LFBlackHole, maintaining the invariant that it really
745 -- is a black hole and not something else.
747 cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
748 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
750 closureCafs = cafs })
751 = ClosureInfo { closureName = nm,
752 closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
753 closureSMRep = BlackHoleRep,
754 closureSRT = NoC_SRT,
758 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
761 --------------------------------------
762 -- Extracting ClosureTypeInfo
763 --------------------------------------
765 -- JD: I've added the continuation arguments not for fun but because
766 -- I don't want to pipe the monad in here (circular module dependencies),
767 -- and I don't want to pull this code out of this module, which would
768 -- require us to expose a bunch of abstract types.
771 ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
772 (ClosureTypeInfo -> a) -> a
773 closureTypeInfo cl_info k_with_con_name k_simple
775 ConInfo { closureCon = con }
776 -> k_with_con_name (ConstrInfo (ptrs, nptrs)
777 (fromIntegral (dataConTagZ con))) con info_lbl
779 --con_name = panic "closureTypeInfo"
781 -- cstr <- mkByteStringCLit $ dataConIdentity con
782 -- con_name = makeRelativeRefTo info_lbl cstr
784 ClosureInfo { closureName = name,
785 closureLFInfo = LFReEntrant _ arity _ arg_descr,
787 -> k_simple $ FunInfo (ptrs, nptrs)
791 (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
793 ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _,
795 -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
797 ClosureInfo { closureLFInfo = LFThunk {},
799 -> k_simple $ ThunkInfo (ptrs, nptrs) srt
801 _ -> panic "unexpected lambda form in mkCmmInfo"
803 info_lbl = infoTableLabelFromCI cl_info
804 ptrs = fromIntegral $ closurePtrsSize cl_info
805 size = fromIntegral $ closureNonHdrSize cl_info
808 --------------------------------------
809 -- Functions about closure *sizes*
810 --------------------------------------
812 closureSize :: ClosureInfo -> WordOff
813 closureSize cl_info = hdr_size + closureNonHdrSize cl_info
814 where hdr_size | closureIsThunk cl_info = thunkHdrSize
815 | otherwise = fixedHdrSize
816 -- All thunks use thunkHdrSize, even if they are non-updatable.
817 -- this is because we don't have separate closure types for
818 -- updatable vs. non-updatable thunks, so the GC can't tell the
819 -- difference. If we ever have significant numbers of non-
820 -- updatable thunks, it might be worth fixing this.
822 closureNonHdrSize :: ClosureInfo -> WordOff
823 closureNonHdrSize cl_info
824 = tot_wds + computeSlopSize tot_wds cl_info
826 tot_wds = closureGoodStuffSize cl_info
828 closureGoodStuffSize :: ClosureInfo -> WordOff
829 closureGoodStuffSize cl_info
830 = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
833 closurePtrsSize :: ClosureInfo -> WordOff
834 closurePtrsSize cl_info
835 = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
839 sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
840 sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs)
841 sizes_from_SMRep BlackHoleRep = (0, 0)
843 -- Computing slop size. WARNING: this looks dodgy --- it has deep
844 -- knowledge of what the storage manager does with the various
845 -- representations...
847 -- Slop Requirements: every thunk gets an extra padding word in the
848 -- header, which takes the the updated value.
850 slopSize :: ClosureInfo -> WordOff
851 slopSize cl_info = computeSlopSize payload_size cl_info
852 where payload_size = closureGoodStuffSize cl_info
854 computeSlopSize :: WordOff -> ClosureInfo -> WordOff
855 computeSlopSize payload_size cl_info
856 = max 0 (minPayloadSize smrep updatable - payload_size)
858 smrep = closureSMRep cl_info
859 updatable = closureNeedsUpdSpace cl_info
861 closureNeedsUpdSpace :: ClosureInfo -> Bool
862 -- We leave space for an update if either (a) the closure is updatable
863 -- or (b) it is a static thunk. This is because a static thunk needs
864 -- a static link field in a predictable place (after the slop), regardless
865 -- of whether it is updatable or not.
866 closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
867 LFThunk TopLevel _ _ _ _ }) = True
868 closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
870 minPayloadSize :: SMRep -> Bool -> WordOff
871 minPayloadSize smrep updatable
873 BlackHoleRep -> min_upd_size
874 GenericRep _ _ _ _ | updatable -> min_upd_size
875 GenericRep True _ _ _ -> 0 -- static
876 GenericRep False _ _ _ -> mIN_PAYLOAD_SIZE
880 ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader)
881 0 -- check that we already have enough
882 -- room for mIN_SIZE_NonUpdHeapObject,
883 -- due to the extra header word in SMP
885 --------------------------------------
886 -- Other functions over ClosureInfo
887 --------------------------------------
889 blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
890 -- Static closures are never themselves black-holed.
891 -- Updatable ones will be overwritten with a CAFList cell, which points to a
893 -- Single-entry ones have no fvs to plug, and we trust they don't form part
896 blackHoleOnEntry _ ConInfo{} = False
897 blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
899 = False -- Never black-hole a static closure
903 LFReEntrant _ _ _ _ -> False
904 LFLetNoEscape -> False
905 LFThunk _ no_fvs updatable _ _
907 then not opt_OmitBlackHoling
908 else doingTickyProfiling dflags || not no_fvs
909 -- the former to catch double entry,
910 -- and the latter to plug space-leaks. KSW/SDM 1999-04.
912 _other -> panic "blackHoleOnEntry" -- Should never happen
915 staticClosureNeedsLink :: ClosureInfo -> Bool
916 -- A static closure needs a link field to aid the GC when traversing
917 -- the static closure graph. But it only needs such a field if either
919 -- b) it's a constructor with one or more pointer fields
920 -- In case (b), the constructor's fields themselves play the role
922 staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
924 staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
925 = not (isNullaryRepDataCon con) && not_nocaf_constr
929 GenericRep _ _ _ ConstrNoCaf -> False
932 isStaticClosure :: ClosureInfo -> Bool
933 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
935 closureUpdReqd :: ClosureInfo -> Bool
936 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
937 closureUpdReqd ConInfo{} = False
939 lfUpdatable :: LambdaFormInfo -> Bool
940 lfUpdatable (LFThunk _ _ upd _ _) = upd
941 lfUpdatable (LFBlackHole _) = True
942 -- Black-hole closures are allocated to receive the results of an
943 -- alg case with a named default... so they need to be updated.
944 lfUpdatable _ = False
946 closureIsThunk :: ClosureInfo -> Bool
947 closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
948 closureIsThunk ConInfo{} = False
950 closureSingleEntry :: ClosureInfo -> Bool
951 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
952 closureSingleEntry _ = False
954 closureReEntrant :: ClosureInfo -> Bool
955 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
956 closureReEntrant _ = False
958 isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
959 isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
960 isConstrClosure_maybe _ = Nothing
962 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
963 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
964 closureFunInfo _ = Nothing
966 lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
967 lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
968 lfFunInfo _ = Nothing
970 funTag :: ClosureInfo -> DynTag
971 funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
972 funTag (ConInfo {}) = panic "funTag"
974 isToplevClosure :: ClosureInfo -> Bool
975 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
977 LFReEntrant TopLevel _ _ _ -> True
978 LFThunk TopLevel _ _ _ _ -> True
980 isToplevClosure _ = False
982 --------------------------------------
984 --------------------------------------
986 infoTableLabelFromCI :: ClosureInfo -> CLabel
987 infoTableLabelFromCI cl@(ClosureInfo { closureName = name,
988 closureLFInfo = lf_info })
990 LFBlackHole info -> info
992 LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
993 mkSelectorInfoLabel upd_flag offset
995 LFThunk _ _ upd_flag (ApThunk arity) _ ->
996 mkApInfoTableLabel upd_flag arity
998 LFThunk{} -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1000 LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1002 _other -> panic "infoTableLabelFromCI"
1004 infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep })
1005 | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl
1006 | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl
1008 name = dataConName con
1010 -- ClosureInfo for a closure (as opposed to a constructor) is always local
1011 closureLabelFromCI :: ClosureInfo -> CLabel
1012 closureLabelFromCI cl@(ClosureInfo { closureName = nm }) =
1013 mkLocalClosureLabel nm $ clHasCafRefs cl
1014 closureLabelFromCI _ = panic "closureLabelFromCI"
1016 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
1017 -- thunkEntryLabel is a local help function, not exported. It's used from both
1018 -- entryLabelFromCI and getCallMethod.
1019 thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
1020 = enterApLabel upd_flag arity
1021 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
1022 = enterSelectorLabel upd_flag offset
1023 thunkEntryLabel thunk_id c _ _
1024 = enterIdLabel thunk_id c
1026 enterApLabel :: Bool -> Arity -> CLabel
1027 enterApLabel is_updatable arity
1028 | tablesNextToCode = mkApInfoTableLabel is_updatable arity
1029 | otherwise = mkApEntryLabel is_updatable arity
1031 enterSelectorLabel :: Bool -> WordOff -> CLabel
1032 enterSelectorLabel upd_flag offset
1033 | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
1034 | otherwise = mkSelectorEntryLabel upd_flag offset
1036 enterIdLabel :: Name -> CafInfo -> CLabel
1038 | tablesNextToCode = mkInfoTableLabel id c
1039 | otherwise = mkEntryLabel id c
1041 enterLocalIdLabel :: Name -> CafInfo -> CLabel
1042 enterLocalIdLabel id c
1043 | tablesNextToCode = mkLocalInfoTableLabel id c
1044 | otherwise = mkLocalEntryLabel id c
1047 --------------------------------------
1049 --------------------------------------
1051 -- Profiling requires two pieces of information to be determined for
1052 -- each closure's info table --- description and type.
1054 -- The description is stored directly in the @CClosureInfoTable@ when the
1055 -- info table is built.
1057 -- The type is determined from the type information stored with the @Id@
1058 -- in the closure info using @closureTypeDescr@.
1060 closureValDescr, closureTypeDescr :: ClosureInfo -> String
1061 closureValDescr (ClosureInfo {closureDescr = descr})
1063 closureValDescr (ConInfo {closureCon = con})
1064 = occNameString (getOccName con)
1066 closureTypeDescr (ClosureInfo { closureType = ty })
1067 = getTyDescription ty
1068 closureTypeDescr (ConInfo { closureCon = data_con })
1069 = occNameString (getOccName (dataConTyCon data_con))
1071 getTyDescription :: Type -> String
1073 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1076 AppTy fun _ -> getTyDescription fun
1077 FunTy _ res -> '-' : '>' : fun_result res
1078 TyConApp tycon _ -> getOccString tycon
1079 PredTy sty -> getPredTyDescription sty
1080 ForAllTy _ ty -> getTyDescription ty
1083 fun_result (FunTy _ res) = '>' : fun_result res
1084 fun_result other = getTyDescription other
1086 getPredTyDescription :: PredType -> String
1087 getPredTyDescription (ClassP cl _) = getOccString cl
1088 getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
1089 getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk?
1092 --------------------------------------
1094 --------------------------------------
1096 -- We need to know whether a closure may have CAFs.
1097 clHasCafRefs :: ClosureInfo -> CafInfo
1098 clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
1099 clHasCafRefs (ConInfo {}) = NoCafRefs