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 -----------------------------------------------------------------------------
15 module StgCmmClosure (
17 DynTag, tagForCon, isSmallFamily,
20 ArgDescr(..), Liveness(..),
23 isVoidRep, isGcPtrRep, addIdReps, addArgReps,
26 LambdaFormInfo, -- Abstract
27 StandardFormInfo, -- ...ditto...
28 mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
29 mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
33 mkClosureInfo, mkConInfo, maybeIsLFCon,
35 closureSize, closureNonHdrSize,
36 closureGoodStuffSize, closurePtrsSize,
39 closureName, infoTableLabelFromCI,
42 closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
43 closureNeedsUpdSpace, closureIsThunk,
44 closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
45 closureFunInfo, isStandardFormThunk, isKnownFun,
48 enterIdLabel, enterLocalIdLabel,
51 CallMethod(..), getCallMethod,
58 closureValDescr, closureTypeDescr, -- profiling
61 cafBlackHoleClosureInfo,
63 staticClosureNeedsLink, clHasCafRefs
66 #include "../includes/MachDeps.h"
68 #define FAST_STRING_NOT_NEEDED
69 #include "HsVersions.h"
71 import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
72 -- XXX temporary becuase FunInfo needs this one
76 import Cmm ( ClosureTypeInfo(..), ConstrDescription )
94 -----------------------------------------------------------------------------
96 -----------------------------------------------------------------------------
98 addIdReps :: [Id] -> [(PrimRep, Id)]
99 addIdReps ids = [(idPrimRep id, id) | id <- ids]
101 addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
102 addArgReps args = [(argPrimRep arg, arg) | arg <- args]
104 argPrimRep :: StgArg -> PrimRep
105 argPrimRep arg = typePrimRep (stgArgType arg)
107 isVoidRep :: PrimRep -> Bool
108 isVoidRep VoidRep = True
109 isVoidRep _other = False
111 isGcPtrRep :: PrimRep -> Bool
112 isGcPtrRep PtrRep = True
116 -----------------------------------------------------------------------------
118 -----------------------------------------------------------------------------
120 -- Information about an identifier, from the code generator's point of
121 -- view. Every identifier is bound to a LambdaFormInfo in the
122 -- environment, which gives the code generator enough info to be able to
123 -- tail call or return that identifier.
126 = LFReEntrant -- Reentrant closure (a function)
127 TopLevelFlag -- True if top level
128 !Int -- Arity. Invariant: always > 0
129 !Bool -- True <=> no fvs
130 ArgDescr -- Argument descriptor (should really be in ClosureInfo)
132 | LFThunk -- Thunk (zero arity)
134 !Bool -- True <=> no free vars
135 !Bool -- True <=> updatable (i.e., *not* single-entry)
137 !Bool -- True <=> *might* be a function type
139 | LFCon -- A saturated constructor application
140 DataCon -- The constructor
142 | LFUnknown -- Used for function arguments and imported things.
143 -- We know nothing about this closure.
144 -- Treat like updatable "LFThunk"...
145 -- Imported things which we *do* know something about use
146 -- one of the other LF constructors (eg LFReEntrant for
148 !Bool -- True <=> *might* be a function type
149 -- The False case is good when we want to enter it,
150 -- because then we know the entry code will do
151 -- For a function, the entry code is the fast entry point
153 | LFUnLifted -- A value of unboxed type;
154 -- always a value, neeeds evaluation
156 | LFLetNoEscape -- See LetNoEscape module for precise description
158 | LFBlackHole -- Used for the closures allocated to hold the result
159 -- of a CAF. We want the target of the update frame to
160 -- be in the heap, so we make a black hole to hold it.
161 CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
164 -------------------------
165 -- An ArgDsecr describes the argument pattern of a function
167 {- XXX -- imported from old ClosureInfo for now
169 = ArgSpec -- Fits one of the standard patterns
170 !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ...
172 | ArgGen -- General case
173 Liveness -- Details about the arguments
176 {- XXX -- imported from old ClosureInfo for now
177 -------------------------
178 -- We represent liveness bitmaps as a Bitmap (whose internal
179 -- representation really is a bitmap). These are pinned onto case return
180 -- vectors to indicate the state of the stack for the garbage collector.
182 -- In the compiled program, liveness bitmaps that fit inside a single
183 -- word (StgWord) are stored as a single word, while larger bitmaps are
184 -- stored as a pointer to an array of words.
187 = SmallLiveness -- Liveness info that fits in one word
188 StgWord -- Here's the bitmap
190 | BigLiveness -- Liveness info witha a multi-word bitmap
191 CLabel -- Label for the bitmap
194 -------------------------
195 -- StandardFormInfo tells whether this thunk has one of
196 -- a small number of standard forms
198 data StandardFormInfo
200 -- Not of of the standard forms
203 -- A SelectorThunk is of form
205 -- con a1,..,an -> ak
206 -- and the constructor is from a single-constr type.
207 WordOff -- 0-origin offset of ak within the "goods" of
208 -- constructor (Recall that the a1,...,an may be laid
209 -- out in the heap in a non-obvious order.)
212 -- An ApThunk is of form
214 -- The code for the thunk just pushes x2..xn on the stack and enters x1.
215 -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
216 -- in the RTS to save space.
220 ------------------------------------------------------
221 -- Building LambdaFormInfo
222 ------------------------------------------------------
224 mkLFArgument :: Id -> LambdaFormInfo
226 | isUnLiftedType ty = LFUnLifted
227 | might_be_a_function ty = LFUnknown True
228 | otherwise = LFUnknown False
233 mkLFLetNoEscape :: LambdaFormInfo
234 mkLFLetNoEscape = LFLetNoEscape
237 mkLFReEntrant :: TopLevelFlag -- True of top level
240 -> ArgDescr -- Argument descriptor
243 mkLFReEntrant top fvs args arg_descr
244 = LFReEntrant top (length args) (null fvs) arg_descr
247 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
248 mkLFThunk thunk_ty top fvs upd_flag
249 = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
250 LFThunk top (null fvs)
251 (isUpdatable upd_flag)
253 (might_be_a_function thunk_ty)
256 might_be_a_function :: Type -> Bool
257 -- Return False only if we are *sure* it's a data type
258 -- Look through newtypes etc as much as poss
259 might_be_a_function ty
260 = case splitTyConApp_maybe (repType ty) of
261 Just (tc, _) -> not (isDataTyCon tc)
265 mkConLFInfo :: DataCon -> LambdaFormInfo
266 mkConLFInfo con = LFCon con
269 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
270 mkSelectorLFInfo id offset updatable
271 = LFThunk NotTopLevel False updatable (SelectorThunk offset)
272 (might_be_a_function (idType id))
275 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
276 mkApLFInfo id upd_flag arity
277 = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
278 (might_be_a_function (idType id))
281 mkLFImported :: Id -> LambdaFormInfo
283 | Just con <- isDataConWorkId_maybe id
284 , isNullaryRepDataCon con
285 = LFCon con -- An imported nullary constructor
286 -- We assume that the constructor is evaluated so that
287 -- the id really does point directly to the constructor
290 = LFReEntrant TopLevel arity True (panic "arg_descr")
293 = mkLFArgument id -- Not sure of exact arity
297 -----------------------------------------------------
298 -- Dynamic pointer tagging
299 -----------------------------------------------------
301 type ConTagZ = Int -- A *zero-indexed* contructor tag
303 type DynTag = Int -- The tag on a *pointer*
304 -- (from the dynamic-tagging paper)
306 {- Note [Data constructor dynamic tags]
307 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
308 The family size of a data type (the number of constructors)
310 * small, if the family size < 2**tag_bits
313 Small families can have the constructor tag in the tag bits.
314 Big families only use the tag value 1 to represent evaluatedness. -}
316 isSmallFamily :: Int -> Bool
317 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
319 -- We keep the *zero-indexed* tag in the srt_len field of the info
320 -- table of a data constructor.
321 dataConTagZ :: DataCon -> ConTagZ
322 dataConTagZ con = dataConTag con - fIRST_TAG
324 tagForCon :: DataCon -> DynTag
326 | isSmallFamily fam_size = con_tag + 1
329 con_tag = dataConTagZ con
330 fam_size = tyConFamilySize (dataConTyCon con)
332 tagForArity :: Int -> DynTag
333 tagForArity arity | isSmallFamily arity = arity
336 lfDynTag :: LambdaFormInfo -> DynTag
337 -- Return the tag in the low order bits of a variable bound
338 -- to this LambdaForm
339 lfDynTag (LFCon con) = tagForCon con
340 lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
344 -----------------------------------------------------------------------------
345 -- Observing LambdaFormInfo
346 -----------------------------------------------------------------------------
349 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
350 maybeIsLFCon (LFCon con) = Just con
351 maybeIsLFCon _ = Nothing
354 isLFThunk :: LambdaFormInfo -> Bool
355 isLFThunk (LFThunk _ _ _ _ _) = True
356 isLFThunk (LFBlackHole _) = True
357 -- return True for a blackhole: this function is used to determine
358 -- whether to use the thunk header in SMP mode, and a blackhole
363 -----------------------------------------------------------------------------
365 -----------------------------------------------------------------------------
368 :: Bool -- True <=> static closure
370 -> WordOff -> WordOff -- Tot wds, ptr wds
373 chooseSMRep is_static lf_info tot_wds ptr_wds
375 nonptr_wds = tot_wds - ptr_wds
376 closure_type = getClosureType is_static ptr_wds lf_info
378 GenericRep is_static ptr_wds nonptr_wds closure_type
380 -- We *do* get non-updatable top-level thunks sometimes. eg. f = g
381 -- gets compiled to a jump to g (if g has non-zero arity), instead of
382 -- messing around with update frames and PAPs. We set the closure type
383 -- to FUN_STATIC in this case.
385 getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
386 getClosureType is_static ptr_wds lf_info
388 LFCon {} | is_static && ptr_wds == 0 -> ConstrNoCaf
389 | otherwise -> Constr
390 LFReEntrant {} -> Fun
391 LFThunk _ _ _ (SelectorThunk {}) _ -> ThunkSelector
393 _ -> panic "getClosureType"
396 -----------------------------------------------------------------------------
398 -----------------------------------------------------------------------------
400 -- Be sure to see the stg-details notes about these...
402 nodeMustPointToIt :: LambdaFormInfo -> Bool
403 nodeMustPointToIt (LFReEntrant top _ no_fvs _)
404 = not no_fvs || -- Certainly if it has fvs we need to point to it
406 -- If it is not top level we will point to it
407 -- We can have a \r closure with no_fvs which
408 -- is not top level as special case cgRhsClosure
409 -- has been dissabled in favour of let floating
411 -- For lex_profiling we also access the cost centre for a
412 -- non-inherited function i.e. not top level
413 -- the not top case above ensures this is ok.
415 nodeMustPointToIt (LFCon _) = True
417 -- Strictly speaking, the above two don't need Node to point
418 -- to it if the arity = 0. But this is a *really* unlikely
419 -- situation. If we know it's nil (say) and we are entering
420 -- it. Eg: let x = [] in x then we will certainly have inlined
421 -- x, since nil is a simple atom. So we gain little by not
422 -- having Node point to known zero-arity things. On the other
423 -- hand, we do lose something; Patrick's code for figuring out
424 -- when something has been updated but not entered relies on
425 -- having Node point to the result of an update. SLPJ
428 nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
429 = updatable || not no_fvs || opt_SccProfilingOn
430 -- For the non-updatable (single-entry case):
432 -- True if has fvs (in which case we need access to them, and we
433 -- should black-hole it)
434 -- or profiling (in which case we need to recover the cost centre
437 nodeMustPointToIt (LFThunk {}) -- Node must point to a standard-form thunk
440 nodeMustPointToIt (LFUnknown _) = True
441 nodeMustPointToIt LFUnLifted = False
442 nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point
443 nodeMustPointToIt LFLetNoEscape = False
445 -----------------------------------------------------------------------------
447 -----------------------------------------------------------------------------
449 {- The entry conventions depend on the type of closure being entered,
450 whether or not it has free variables, and whether we're running
451 sequentially or in parallel.
453 Closure Node Argument Enter
454 Characteristics Par Req'd Passing Via
455 -------------------------------------------------------------------------------
456 Unknown & no & yes & stack & node
457 Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args)
458 & slow entry (otherwise)
459 Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args)
460 0 arg, no fvs \r,\s & no & no & n/a & direct entry
461 0 arg, no fvs \u & no & yes & n/a & node
462 0 arg, fvs \r,\s & no & yes & n/a & direct entry
463 0 arg, fvs \u & no & yes & n/a & node
465 Unknown & yes & yes & stack & node
466 Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args)
467 & slow entry (otherwise)
468 Known fun (>1 arg), fvs & yes & yes & registers & node
469 0 arg, no fvs \r,\s & yes & no & n/a & direct entry
470 0 arg, no fvs \u & yes & yes & n/a & node
471 0 arg, fvs \r,\s & yes & yes & n/a & node
472 0 arg, fvs \u & yes & yes & n/a & node
475 When black-holing, single-entry closures could also be entered via node
476 (rather than directly) to catch double-entry. -}
479 = EnterIt -- No args, not a function
481 | JumpToIt -- A join point
483 | ReturnIt -- It's a value (function, unboxed value,
484 -- or constructor), so just return it.
486 | SlowCall -- Unknown fun, or known fun with
489 | DirectEntry -- Jump directly, with args in regs
490 CLabel -- The code label
493 getCallMethod :: DynFlags
494 -> Name -- Function being applied
495 -> CafInfo -- Can it refer to CAF's?
496 -> LambdaFormInfo -- Its info
497 -> Int -- Number of available arguments
500 getCallMethod _ _name _ lf_info _n_args
501 | nodeMustPointToIt lf_info && opt_Parallel
502 = -- If we're parallel, then we must always enter via node.
503 -- The reason is that the closure may have been
504 -- fetched since we allocated it.
507 getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
508 | n_args == 0 = ASSERT( arity /= 0 )
509 ReturnIt -- No args at all
510 | n_args < arity = SlowCall -- Not enough args
511 | otherwise = DirectEntry (enterIdLabel name caf) arity
513 getCallMethod _ _name _ LFUnLifted n_args
514 = ASSERT( n_args == 0 ) ReturnIt
516 getCallMethod _ _name _ (LFCon _) n_args
517 = ASSERT( n_args == 0 ) ReturnIt
519 getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
520 | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
521 = SlowCall -- We cannot just enter it [in eval/apply, the entry code
522 -- is the fast-entry code]
524 -- Since is_fun is False, we are *definitely* looking at a data value
525 | updatable || doingTickyProfiling dflags -- to catch double entry
527 I decided to remove this, because in SMP mode it doesn't matter
528 if we enter the same thunk multiple times, so the optimisation
529 of jumping directly to the entry code is still valid. --SDM
532 -- We used to have ASSERT( n_args == 0 ), but actually it is
533 -- possible for the optimiser to generate
534 -- let bot :: Int = error Int "urk"
535 -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
536 -- This happens as a result of the case-of-error transformation
537 -- So the right thing to do is just to enter the thing
539 | otherwise -- Jump direct to code for single-entry thunks
540 = ASSERT( n_args == 0 )
541 DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
543 getCallMethod _ _name _ (LFUnknown True) _n_args
544 = SlowCall -- might be a function
546 getCallMethod _ name _ (LFUnknown False) n_args
547 = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
548 EnterIt -- Not a function
550 getCallMethod _ _name _ (LFBlackHole _) _n_args
551 = SlowCall -- Presumably the black hole has by now
552 -- been updated, but we don't know with
553 -- what, so we slow call it
555 getCallMethod _ _name _ LFLetNoEscape _n_args
558 isStandardFormThunk :: LambdaFormInfo -> Bool
559 isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
560 isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
561 isStandardFormThunk _other_lf_info = False
563 isKnownFun :: LambdaFormInfo -> Bool
564 isKnownFun (LFReEntrant _ _ _ _) = True
565 isKnownFun LFLetNoEscape = True
568 -----------------------------------------------------------------------------
569 -- staticClosureRequired
570 -----------------------------------------------------------------------------
572 {- staticClosureRequired is never called (hence commented out)
574 SimonMar writes (Sept 07) It's an optimisation we used to apply at
575 one time, I believe, but it got lost probably in the rewrite of
576 the RTS/code generator. I left that code there to remind me to
577 look into whether it was worth doing sometime
579 {- Avoiding generating entries and info tables
580 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
581 At present, for every function we generate all of the following,
582 just in case. But they aren't always all needed, as noted below:
584 [NB1: all of this applies only to *functions*. Thunks always
585 have closure, info table, and entry code.]
587 [NB2: All are needed if the function is *exported*, just to play safe.]
589 * Fast-entry code ALWAYS NEEDED
592 Needed iff (a) we have any un-saturated calls to the function
593 OR (b) the function is passed as an arg
594 OR (c) we're in the parallel world and the function has free vars
595 [Reason: in parallel world, we always enter functions
596 with free vars via the closure.]
598 * The function closure
599 Needed iff (a) we have any un-saturated calls to the function
600 OR (b) the function is passed as an arg
601 OR (c) if the function has free vars (ie not top level)
603 Why case (a) here? Because if the arg-satis check fails,
604 UpdatePAP stuffs a pointer to the function closure in the PAP.
605 [Could be changed; UpdatePAP could stuff in a code ptr instead,
606 but doesn't seem worth it.]
608 [NB: these conditions imply that we might need the closure
609 without the slow-entry code. Here's how.
611 f x y = let g w = ...x..y..w...
615 Here we need a closure for g which contains x and y,
616 but since the calls are all saturated we just jump to the
617 fast entry point for g, with R1 pointing to the closure for g.]
620 * Standard info table
621 Needed iff (a) we have any un-saturated calls to the function
622 OR (b) the function is passed as an arg
623 OR (c) the function has free vars (ie not top level)
625 NB. In the sequential world, (c) is only required so that the function closure has
626 an info table to point to, to keep the storage manager happy.
627 If (c) alone is true we could fake up an info table by choosing
628 one of a standard family of info tables, whose entry code just
631 [NB In the parallel world (c) is needed regardless because
632 we enter functions with free vars via the closure.]
634 If (c) is retained, then we'll sometimes generate an info table
635 (for storage mgr purposes) without slow-entry code. Then we need
636 to use an error label in the info table to substitute for the absent
640 staticClosureRequired
645 staticClosureRequired binder bndr_info
646 (LFReEntrant top_level _ _ _) -- It's a function
647 = ASSERT( isTopLevel top_level )
648 -- Assumption: it's a top-level, no-free-var binding
649 not (satCallsOnly bndr_info)
651 staticClosureRequired binder other_binder_info other_lf_info = True
654 -----------------------------------------------------------------------------
655 -- Data types for closure information}
656 -----------------------------------------------------------------------------
659 {- Information about a closure, from the code generator's point of view.
661 A ClosureInfo decribes the info pointer of a closure. It has
663 a) to construct the info table itself
664 b) to allocate a closure containing that info pointer (i.e.
665 it knows the info table label)
667 We make a ClosureInfo for
668 - each let binding (both top level and not)
669 - each data constructor (for its shared static and
675 closureName :: !Name, -- The thing bound to this closure
676 closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
677 closureSMRep :: !SMRep, -- representation used by storage mgr
678 closureSRT :: !C_SRT, -- What SRT applies to this closure
679 closureType :: !Type, -- Type of closure (ToDo: remove)
680 closureDescr :: !String, -- closure description (for profiling)
681 closureCafs :: !CafInfo -- whether the closure may have CAFs
684 -- Constructor closures don't have a unique info table label (they use
685 -- the constructor's info table), and they don't have an SRT.
687 closureCon :: !DataCon,
688 closureSMRep :: !SMRep
691 {- XXX temp imported from old ClosureInfo
692 -- C_SRT is what StgSyn.SRT gets translated to...
693 -- we add a label for the table, and expect only the 'offset/length' form
696 | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
699 instance Outputable C_SRT where
700 ppr (NoC_SRT) = ptext SLIT("_no_srt_")
701 ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
704 needsSRT :: C_SRT -> Bool
705 needsSRT NoC_SRT = False
706 needsSRT (C_SRT _ _ _) = True
709 --------------------------------------
710 -- Building ClosureInfos
711 --------------------------------------
713 mkClosureInfo :: Bool -- Is static
716 -> Int -> Int -- Total and pointer words
718 -> String -- String descriptor
720 mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
721 = ClosureInfo { closureName = name,
722 closureLFInfo = lf_info,
723 closureSMRep = sm_rep,
724 closureSRT = srt_info,
725 closureType = idType id,
726 closureDescr = descr,
727 closureCafs = idCafInfo id }
730 sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
732 mkConInfo :: Bool -- Is static
734 -> Int -> Int -- Total and pointer words
736 mkConInfo is_static data_con tot_wds ptr_wds
737 = ConInfo { closureSMRep = sm_rep,
738 closureCon = data_con }
740 sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
743 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
744 -- want to allocate the black hole on entry to a CAF. These are the only
745 -- ways to build an LFBlackHole, maintaining the invariant that it really
746 -- is a black hole and not something else.
748 cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
749 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
751 closureCafs = cafs })
752 = ClosureInfo { closureName = nm,
753 closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
754 closureSMRep = BlackHoleRep,
755 closureSRT = NoC_SRT,
759 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
762 --------------------------------------
763 -- Extracting ClosureTypeInfo
764 --------------------------------------
766 -- JD: I've added the continuation arguments not for fun but because
767 -- I don't want to pipe the monad in here (circular module dependencies),
768 -- and I don't want to pull this code out of this module, which would
769 -- require us to expose a bunch of abstract types.
772 ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
773 (ClosureTypeInfo -> a) -> a
774 closureTypeInfo cl_info k_with_con_name k_simple
776 ConInfo { closureCon = con }
777 -> k_with_con_name (ConstrInfo (ptrs, nptrs)
778 (fromIntegral (dataConTagZ con))) con info_lbl
780 --con_name = panic "closureTypeInfo"
782 -- cstr <- mkByteStringCLit $ dataConIdentity con
783 -- con_name = makeRelativeRefTo info_lbl cstr
785 ClosureInfo { closureName = name,
786 closureLFInfo = LFReEntrant _ arity _ arg_descr,
788 -> k_simple $ FunInfo (ptrs, nptrs)
792 (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
794 ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _,
796 -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
798 ClosureInfo { closureLFInfo = LFThunk {},
800 -> k_simple $ ThunkInfo (ptrs, nptrs) srt
802 _ -> panic "unexpected lambda form in mkCmmInfo"
804 info_lbl = infoTableLabelFromCI cl_info
805 ptrs = fromIntegral $ closurePtrsSize cl_info
806 size = fromIntegral $ closureNonHdrSize cl_info
809 --------------------------------------
810 -- Functions about closure *sizes*
811 --------------------------------------
813 closureSize :: ClosureInfo -> WordOff
814 closureSize cl_info = hdr_size + closureNonHdrSize cl_info
815 where hdr_size | closureIsThunk cl_info = thunkHdrSize
816 | otherwise = fixedHdrSize
817 -- All thunks use thunkHdrSize, even if they are non-updatable.
818 -- this is because we don't have separate closure types for
819 -- updatable vs. non-updatable thunks, so the GC can't tell the
820 -- difference. If we ever have significant numbers of non-
821 -- updatable thunks, it might be worth fixing this.
823 closureNonHdrSize :: ClosureInfo -> WordOff
824 closureNonHdrSize cl_info
825 = tot_wds + computeSlopSize tot_wds cl_info
827 tot_wds = closureGoodStuffSize cl_info
829 closureGoodStuffSize :: ClosureInfo -> WordOff
830 closureGoodStuffSize cl_info
831 = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
834 closurePtrsSize :: ClosureInfo -> WordOff
835 closurePtrsSize cl_info
836 = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
840 sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
841 sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs)
842 sizes_from_SMRep BlackHoleRep = (0, 0)
844 -- Computing slop size. WARNING: this looks dodgy --- it has deep
845 -- knowledge of what the storage manager does with the various
846 -- representations...
848 -- Slop Requirements: every thunk gets an extra padding word in the
849 -- header, which takes the the updated value.
851 slopSize :: ClosureInfo -> WordOff
852 slopSize cl_info = computeSlopSize payload_size cl_info
853 where payload_size = closureGoodStuffSize cl_info
855 computeSlopSize :: WordOff -> ClosureInfo -> WordOff
856 computeSlopSize payload_size cl_info
857 = max 0 (minPayloadSize smrep updatable - payload_size)
859 smrep = closureSMRep cl_info
860 updatable = closureNeedsUpdSpace cl_info
862 closureNeedsUpdSpace :: ClosureInfo -> Bool
863 -- We leave space for an update if either (a) the closure is updatable
864 -- or (b) it is a static thunk. This is because a static thunk needs
865 -- a static link field in a predictable place (after the slop), regardless
866 -- of whether it is updatable or not.
867 closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
868 LFThunk TopLevel _ _ _ _ }) = True
869 closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
871 minPayloadSize :: SMRep -> Bool -> WordOff
872 minPayloadSize smrep updatable
874 BlackHoleRep -> min_upd_size
875 GenericRep _ _ _ _ | updatable -> min_upd_size
876 GenericRep True _ _ _ -> 0 -- static
877 GenericRep False _ _ _ -> mIN_PAYLOAD_SIZE
881 ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader)
882 0 -- check that we already have enough
883 -- room for mIN_SIZE_NonUpdHeapObject,
884 -- due to the extra header word in SMP
886 --------------------------------------
887 -- Other functions over ClosureInfo
888 --------------------------------------
890 blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
891 -- Static closures are never themselves black-holed.
892 -- Updatable ones will be overwritten with a CAFList cell, which points to a
894 -- Single-entry ones have no fvs to plug, and we trust they don't form part
897 blackHoleOnEntry _ ConInfo{} = False
898 blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
900 = False -- Never black-hole a static closure
904 LFReEntrant _ _ _ _ -> False
905 LFLetNoEscape -> False
906 LFThunk _ no_fvs updatable _ _
908 then not opt_OmitBlackHoling
909 else doingTickyProfiling dflags || not no_fvs
910 -- the former to catch double entry,
911 -- and the latter to plug space-leaks. KSW/SDM 1999-04.
913 _other -> panic "blackHoleOnEntry" -- Should never happen
916 staticClosureNeedsLink :: ClosureInfo -> Bool
917 -- A static closure needs a link field to aid the GC when traversing
918 -- the static closure graph. But it only needs such a field if either
920 -- b) it's a constructor with one or more pointer fields
921 -- In case (b), the constructor's fields themselves play the role
923 staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
925 staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
926 = not (isNullaryRepDataCon con) && not_nocaf_constr
930 GenericRep _ _ _ ConstrNoCaf -> False
933 isStaticClosure :: ClosureInfo -> Bool
934 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
936 closureUpdReqd :: ClosureInfo -> Bool
937 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
938 closureUpdReqd ConInfo{} = False
940 lfUpdatable :: LambdaFormInfo -> Bool
941 lfUpdatable (LFThunk _ _ upd _ _) = upd
942 lfUpdatable (LFBlackHole _) = True
943 -- Black-hole closures are allocated to receive the results of an
944 -- alg case with a named default... so they need to be updated.
945 lfUpdatable _ = False
947 closureIsThunk :: ClosureInfo -> Bool
948 closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
949 closureIsThunk ConInfo{} = False
951 closureSingleEntry :: ClosureInfo -> Bool
952 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
953 closureSingleEntry _ = False
955 closureReEntrant :: ClosureInfo -> Bool
956 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
957 closureReEntrant _ = False
959 isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
960 isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
961 isConstrClosure_maybe _ = Nothing
963 closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
964 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
965 closureFunInfo _ = Nothing
967 lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
968 lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
969 lfFunInfo _ = Nothing
971 funTag :: ClosureInfo -> DynTag
972 funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
973 funTag (ConInfo {}) = panic "funTag"
975 isToplevClosure :: ClosureInfo -> Bool
976 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
978 LFReEntrant TopLevel _ _ _ -> True
979 LFThunk TopLevel _ _ _ _ -> True
981 isToplevClosure _ = False
983 --------------------------------------
985 --------------------------------------
987 infoTableLabelFromCI :: ClosureInfo -> CLabel
988 infoTableLabelFromCI cl@(ClosureInfo { closureName = name,
989 closureLFInfo = lf_info })
991 LFBlackHole info -> info
993 LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
994 mkSelectorInfoLabel upd_flag offset
996 LFThunk _ _ upd_flag (ApThunk arity) _ ->
997 mkApInfoTableLabel upd_flag arity
999 LFThunk{} -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1001 LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl
1003 _other -> panic "infoTableLabelFromCI"
1005 infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep })
1006 | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl
1007 | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl
1009 name = dataConName con
1011 -- ClosureInfo for a closure (as opposed to a constructor) is always local
1012 closureLabelFromCI :: ClosureInfo -> CLabel
1013 closureLabelFromCI cl@(ClosureInfo { closureName = nm }) =
1014 mkLocalClosureLabel nm $ clHasCafRefs cl
1015 closureLabelFromCI _ = panic "closureLabelFromCI"
1017 thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
1018 -- thunkEntryLabel is a local help function, not exported. It's used from both
1019 -- entryLabelFromCI and getCallMethod.
1020 thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
1021 = enterApLabel upd_flag arity
1022 thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
1023 = enterSelectorLabel upd_flag offset
1024 thunkEntryLabel thunk_id c _ _
1025 = enterIdLabel thunk_id c
1027 enterApLabel :: Bool -> Arity -> CLabel
1028 enterApLabel is_updatable arity
1029 | tablesNextToCode = mkApInfoTableLabel is_updatable arity
1030 | otherwise = mkApEntryLabel is_updatable arity
1032 enterSelectorLabel :: Bool -> WordOff -> CLabel
1033 enterSelectorLabel upd_flag offset
1034 | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
1035 | otherwise = mkSelectorEntryLabel upd_flag offset
1037 enterIdLabel :: Name -> CafInfo -> CLabel
1039 | tablesNextToCode = mkInfoTableLabel id c
1040 | otherwise = mkEntryLabel id c
1042 enterLocalIdLabel :: Name -> CafInfo -> CLabel
1043 enterLocalIdLabel id c
1044 | tablesNextToCode = mkLocalInfoTableLabel id c
1045 | otherwise = mkLocalEntryLabel id c
1048 --------------------------------------
1050 --------------------------------------
1052 -- Profiling requires two pieces of information to be determined for
1053 -- each closure's info table --- description and type.
1055 -- The description is stored directly in the @CClosureInfoTable@ when the
1056 -- info table is built.
1058 -- The type is determined from the type information stored with the @Id@
1059 -- in the closure info using @closureTypeDescr@.
1061 closureValDescr, closureTypeDescr :: ClosureInfo -> String
1062 closureValDescr (ClosureInfo {closureDescr = descr})
1064 closureValDescr (ConInfo {closureCon = con})
1065 = occNameString (getOccName con)
1067 closureTypeDescr (ClosureInfo { closureType = ty })
1068 = getTyDescription ty
1069 closureTypeDescr (ConInfo { closureCon = data_con })
1070 = occNameString (getOccName (dataConTyCon data_con))
1072 getTyDescription :: Type -> String
1074 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1077 AppTy fun _ -> getTyDescription fun
1078 FunTy _ res -> '-' : '>' : fun_result res
1079 TyConApp tycon _ -> getOccString tycon
1080 PredTy sty -> getPredTyDescription sty
1081 ForAllTy _ ty -> getTyDescription ty
1084 fun_result (FunTy _ res) = '>' : fun_result res
1085 fun_result other = getTyDescription other
1087 getPredTyDescription :: PredType -> String
1088 getPredTyDescription (ClassP cl _) = getOccString cl
1089 getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
1090 getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk?
1093 --------------------------------------
1095 --------------------------------------
1097 -- We need to know whether a closure may have CAFs.
1098 clHasCafRefs :: ClosureInfo -> CafInfo
1099 clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
1100 clHasCafRefs (ConInfo {}) = NoCafRefs