Cache the number of data cons in DataTyCon and SumTyCon
[ghc.git] / compiler / codeGen / StgCmmClosure.hs
1 {-# LANGUAGE CPP, RecordWildCards #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Stg to C-- code generation:
6 --
7 -- The types LambdaFormInfo
8 -- ClosureInfo
9 --
10 -- Nothing monadic in here!
11 --
12 -----------------------------------------------------------------------------
13
14 module StgCmmClosure (
15 DynTag, tagForCon, isSmallFamily,
16
17 idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
18 argPrimRep,
19
20 NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
21 assertNonVoidIds, assertNonVoidStgArgs,
22
23 -- * LambdaFormInfo
24 LambdaFormInfo, -- Abstract
25 StandardFormInfo, -- ...ditto...
26 mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
27 mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
28 mkLFStringLit,
29 lfDynTag,
30 maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
31
32 -- * Used by other modules
33 CgLoc(..), SelfLoopInfo, CallMethod(..),
34 nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,
35
36 -- * ClosureInfo
37 ClosureInfo,
38 mkClosureInfo,
39 mkCmmInfo,
40
41 -- ** Inspection
42 closureLFInfo, closureName,
43
44 -- ** Labels
45 -- These just need the info table label
46 closureInfoLabel, staticClosureLabel,
47 closureSlowEntryLabel, closureLocalEntryLabel,
48
49 -- ** Predicates
50 -- These are really just functions on LambdaFormInfo
51 closureUpdReqd, closureSingleEntry,
52 closureReEntrant, closureFunInfo,
53 isToplevClosure,
54
55 blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep
56 isStaticClosure, -- Needs SMPre
57
58 -- * InfoTables
59 mkDataConInfoTable,
60 cafBlackHoleInfoTable,
61 indStaticInfoTable,
62 staticClosureNeedsLink,
63 ) where
64
65 #include "../includes/MachDeps.h"
66
67 #include "HsVersions.h"
68
69 import GhcPrelude
70
71 import StgSyn
72 import SMRep
73 import Cmm
74 import PprCmmExpr()
75
76 import BlockId
77 import CLabel
78 import Id
79 import IdInfo
80 import DataCon
81 import Name
82 import Type
83 import TyCoRep
84 import TcType
85 import TyCon
86 import RepType
87 import BasicTypes
88 import Outputable
89 import DynFlags
90 import Util
91
92 import Data.Coerce (coerce)
93
94 -----------------------------------------------------------------------------
95 -- Data types and synonyms
96 -----------------------------------------------------------------------------
97
98 -- These data types are mostly used by other modules, especially StgCmmMonad,
99 -- but we define them here because some functions in this module need to
100 -- have access to them as well
101
102 data CgLoc
103 = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning
104 -- Hp, so that it remains valid across calls
105
106 | LneLoc BlockId [LocalReg] -- A join point
107 -- A join point (= let-no-escape) should only
108 -- be tail-called, and in a saturated way.
109 -- To tail-call it, assign to these locals,
110 -- and branch to the block id
111
112 instance Outputable CgLoc where
113 ppr (CmmLoc e) = text "cmm" <+> ppr e
114 ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs
115
116 type SelfLoopInfo = (Id, BlockId, [LocalReg])
117
118 -- used by ticky profiling
119 isKnownFun :: LambdaFormInfo -> Bool
120 isKnownFun LFReEntrant{} = True
121 isKnownFun LFLetNoEscape = True
122 isKnownFun _ = False
123
124
125 -------------------------------------
126 -- Non-void types
127 -------------------------------------
128 -- We frequently need the invariant that an Id or a an argument
129 -- is of a non-void type. This type is a witness to the invariant.
130
131 newtype NonVoid a = NonVoid a
132 deriving (Eq, Show)
133
134 fromNonVoid :: NonVoid a -> a
135 fromNonVoid (NonVoid a) = a
136
137 instance (Outputable a) => Outputable (NonVoid a) where
138 ppr (NonVoid a) = ppr a
139
140 nonVoidIds :: [Id] -> [NonVoid Id]
141 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]
142
143 -- | Used in places where some invariant ensures that all these Ids are
144 -- non-void; e.g. constructor field binders in case expressions.
145 -- See Note [Post-unarisation invariants] in UnariseStg.
146 assertNonVoidIds :: [Id] -> [NonVoid Id]
147 assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))
148 coerce ids
149
150 nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
151 nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]
152
153 -- | Used in places where some invariant ensures that all these arguments are
154 -- non-void; e.g. constructor arguments.
155 -- See Note [Post-unarisation invariants] in UnariseStg.
156 assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
157 assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
158 coerce args
159
160
161 -----------------------------------------------------------------------------
162 -- Representations
163 -----------------------------------------------------------------------------
164
165 -- Why are these here?
166
167 idPrimRep :: Id -> PrimRep
168 idPrimRep id = typePrimRep1 (idType id)
169 -- NB: typePrimRep1 fails on unboxed tuples,
170 -- but by StgCmm no Ids have unboxed tuple type
171
172 addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
173 addIdReps = map (\id -> let id' = fromNonVoid id
174 in NonVoid (idPrimRep id', id'))
175
176 addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
177 addArgReps = map (\arg -> let arg' = fromNonVoid arg
178 in NonVoid (argPrimRep arg', arg'))
179
180 argPrimRep :: StgArg -> PrimRep
181 argPrimRep arg = typePrimRep1 (stgArgType arg)
182
183
184 -----------------------------------------------------------------------------
185 -- LambdaFormInfo
186 -----------------------------------------------------------------------------
187
188 -- Information about an identifier, from the code generator's point of
189 -- view. Every identifier is bound to a LambdaFormInfo in the
190 -- environment, which gives the code generator enough info to be able to
191 -- tail call or return that identifier.
192
193 data LambdaFormInfo
194 = LFReEntrant -- Reentrant closure (a function)
195 TopLevelFlag -- True if top level
196 OneShotInfo
197 !RepArity -- Arity. Invariant: always > 0
198 !Bool -- True <=> no fvs
199 ArgDescr -- Argument descriptor (should really be in ClosureInfo)
200
201 | LFThunk -- Thunk (zero arity)
202 TopLevelFlag
203 !Bool -- True <=> no free vars
204 !Bool -- True <=> updatable (i.e., *not* single-entry)
205 StandardFormInfo
206 !Bool -- True <=> *might* be a function type
207
208 | LFCon -- A saturated constructor application
209 DataCon -- The constructor
210
211 | LFUnknown -- Used for function arguments and imported things.
212 -- We know nothing about this closure.
213 -- Treat like updatable "LFThunk"...
214 -- Imported things which we *do* know something about use
215 -- one of the other LF constructors (eg LFReEntrant for
216 -- known functions)
217 !Bool -- True <=> *might* be a function type
218 -- The False case is good when we want to enter it,
219 -- because then we know the entry code will do
220 -- For a function, the entry code is the fast entry point
221
222 | LFUnlifted -- A value of unboxed type;
223 -- always a value, needs evaluation
224
225 | LFLetNoEscape -- See LetNoEscape module for precise description
226
227
228 -------------------------
229 -- StandardFormInfo tells whether this thunk has one of
230 -- a small number of standard forms
231
232 data StandardFormInfo
233 = NonStandardThunk
234 -- The usual case: not of the standard forms
235
236 | SelectorThunk
237 -- A SelectorThunk is of form
238 -- case x of
239 -- con a1,..,an -> ak
240 -- and the constructor is from a single-constr type.
241 WordOff -- 0-origin offset of ak within the "goods" of
242 -- constructor (Recall that the a1,...,an may be laid
243 -- out in the heap in a non-obvious order.)
244
245 | ApThunk
246 -- An ApThunk is of form
247 -- x1 ... xn
248 -- The code for the thunk just pushes x2..xn on the stack and enters x1.
249 -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
250 -- in the RTS to save space.
251 RepArity -- Arity, n
252
253
254 ------------------------------------------------------
255 -- Building LambdaFormInfo
256 ------------------------------------------------------
257
258 mkLFArgument :: Id -> LambdaFormInfo
259 mkLFArgument id
260 | isUnliftedType ty = LFUnlifted
261 | might_be_a_function ty = LFUnknown True
262 | otherwise = LFUnknown False
263 where
264 ty = idType id
265
266 -------------
267 mkLFLetNoEscape :: LambdaFormInfo
268 mkLFLetNoEscape = LFLetNoEscape
269
270 -------------
271 mkLFReEntrant :: TopLevelFlag -- True of top level
272 -> [Id] -- Free vars
273 -> [Id] -- Args
274 -> ArgDescr -- Argument descriptor
275 -> LambdaFormInfo
276
277 mkLFReEntrant _ _ [] _
278 = pprPanic "mkLFReEntrant" empty
279 mkLFReEntrant top fvs args arg_descr
280 = LFReEntrant top os_info (length args) (null fvs) arg_descr
281 where os_info = idOneShotInfo (head args)
282
283 -------------
284 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
285 mkLFThunk thunk_ty top fvs upd_flag
286 = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
287 LFThunk top (null fvs)
288 (isUpdatable upd_flag)
289 NonStandardThunk
290 (might_be_a_function thunk_ty)
291
292 --------------
293 might_be_a_function :: Type -> Bool
294 -- Return False only if we are *sure* it's a data type
295 -- Look through newtypes etc as much as poss
296 might_be_a_function ty
297 | [LiftedRep] <- typePrimRep ty
298 , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
299 , isDataTyCon tc
300 = False
301 | otherwise
302 = True
303
304 -------------
305 mkConLFInfo :: DataCon -> LambdaFormInfo
306 mkConLFInfo con = LFCon con
307
308 -------------
309 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
310 mkSelectorLFInfo id offset updatable
311 = LFThunk NotTopLevel False updatable (SelectorThunk offset)
312 (might_be_a_function (idType id))
313
314 -------------
315 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
316 mkApLFInfo id upd_flag arity
317 = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
318 (might_be_a_function (idType id))
319
320 -------------
321 mkLFImported :: Id -> LambdaFormInfo
322 mkLFImported id
323 | Just con <- isDataConWorkId_maybe id
324 , isNullaryRepDataCon con
325 = LFCon con -- An imported nullary constructor
326 -- We assume that the constructor is evaluated so that
327 -- the id really does point directly to the constructor
328
329 | arity > 0
330 = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
331
332 | otherwise
333 = mkLFArgument id -- Not sure of exact arity
334 where
335 arity = idFunRepArity id
336
337 -------------
338 mkLFStringLit :: LambdaFormInfo
339 mkLFStringLit = LFUnlifted
340
341 -----------------------------------------------------
342 -- Dynamic pointer tagging
343 -----------------------------------------------------
344
345 type DynTag = Int -- The tag on a *pointer*
346 -- (from the dynamic-tagging paper)
347
348 -- Note [Data constructor dynamic tags]
349 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 --
351 -- The family size of a data type (the number of constructors
352 -- or the arity of a function) can be either:
353 -- * small, if the family size < 2**tag_bits
354 -- * big, otherwise.
355 --
356 -- Small families can have the constructor tag in the tag bits.
357 -- Big families only use the tag value 1 to represent evaluatedness.
358 -- We don't have very many tag bits: for example, we have 2 bits on
359 -- x86-32 and 3 bits on x86-64.
360
361 isSmallFamily :: DynFlags -> Int -> Bool
362 isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
363
364 tagForCon :: DynFlags -> DataCon -> DynTag
365 tagForCon dflags con
366 | isSmallFamily dflags fam_size = con_tag
367 | otherwise = 1
368 where
369 con_tag = dataConTag con -- NB: 1-indexed
370 fam_size = tyConFamilySize (dataConTyCon con)
371
372 tagForArity :: DynFlags -> RepArity -> DynTag
373 tagForArity dflags arity
374 | isSmallFamily dflags arity = arity
375 | otherwise = 0
376
377 lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
378 -- Return the tag in the low order bits of a variable bound
379 -- to this LambdaForm
380 lfDynTag dflags (LFCon con) = tagForCon dflags con
381 lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
382 lfDynTag _ _other = 0
383
384
385 -----------------------------------------------------------------------------
386 -- Observing LambdaFormInfo
387 -----------------------------------------------------------------------------
388
389 -------------
390 maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
391 maybeIsLFCon (LFCon con) = Just con
392 maybeIsLFCon _ = Nothing
393
394 ------------
395 isLFThunk :: LambdaFormInfo -> Bool
396 isLFThunk (LFThunk {}) = True
397 isLFThunk _ = False
398
399 isLFReEntrant :: LambdaFormInfo -> Bool
400 isLFReEntrant (LFReEntrant {}) = True
401 isLFReEntrant _ = False
402
403 -----------------------------------------------------------------------------
404 -- Choosing SM reps
405 -----------------------------------------------------------------------------
406
407 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
408 lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
409 lfClosureType (LFCon con) = Constr (dataConTagZ con)
410 (dataConIdentity con)
411 lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
412 lfClosureType _ = panic "lfClosureType"
413
414 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
415 thunkClosureType (SelectorThunk off) = ThunkSelector off
416 thunkClosureType _ = Thunk
417
418 -- We *do* get non-updatable top-level thunks sometimes. eg. f = g
419 -- gets compiled to a jump to g (if g has non-zero arity), instead of
420 -- messing around with update frames and PAPs. We set the closure type
421 -- to FUN_STATIC in this case.
422
423 -----------------------------------------------------------------------------
424 -- nodeMustPointToIt
425 -----------------------------------------------------------------------------
426
427 nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
428 -- If nodeMustPointToIt is true, then the entry convention for
429 -- this closure has R1 (the "Node" register) pointing to the
430 -- closure itself --- the "self" argument
431
432 nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
433 = not no_fvs -- Certainly if it has fvs we need to point to it
434 || isNotTopLevel top -- See Note [GC recovery]
435 -- For lex_profiling we also access the cost centre for a
436 -- non-inherited (i.e. non-top-level) function.
437 -- The isNotTopLevel test above ensures this is ok.
438
439 nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
440 = not no_fvs -- Self parameter
441 || isNotTopLevel top -- Note [GC recovery]
442 || updatable -- Need to push update frame
443 || gopt Opt_SccProfilingOn dflags
444 -- For the non-updatable (single-entry case):
445 --
446 -- True if has fvs (in which case we need access to them, and we
447 -- should black-hole it)
448 -- or profiling (in which case we need to recover the cost centre
449 -- from inside it) ToDo: do we need this even for
450 -- top-level thunks? If not,
451 -- isNotTopLevel subsumes this
452
453 nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk
454 = True
455
456 nodeMustPointToIt _ (LFCon _) = True
457
458 -- Strictly speaking, the above two don't need Node to point
459 -- to it if the arity = 0. But this is a *really* unlikely
460 -- situation. If we know it's nil (say) and we are entering
461 -- it. Eg: let x = [] in x then we will certainly have inlined
462 -- x, since nil is a simple atom. So we gain little by not
463 -- having Node point to known zero-arity things. On the other
464 -- hand, we do lose something; Patrick's code for figuring out
465 -- when something has been updated but not entered relies on
466 -- having Node point to the result of an update. SLPJ
467 -- 27/11/92.
468
469 nodeMustPointToIt _ (LFUnknown _) = True
470 nodeMustPointToIt _ LFUnlifted = False
471 nodeMustPointToIt _ LFLetNoEscape = False
472
473 {- Note [GC recovery]
474 ~~~~~~~~~~~~~~~~~~~~~
475 If we a have a local let-binding (function or thunk)
476 let f = <body> in ...
477 AND <body> allocates, then the heap-overflow check needs to know how
478 to re-start the evaluation. It uses the "self" pointer to do this.
479 So even if there are no free variables in <body>, we still make
480 nodeMustPointToIt be True for non-top-level bindings.
481
482 Why do any such bindings exist? After all, let-floating should have
483 floated them out. Well, a clever optimiser might leave one there to
484 avoid a space leak, deliberately recomputing a thunk. Also (and this
485 really does happen occasionally) let-floating may make a function f smaller
486 so it can be inlined, so now (f True) may generate a local no-fv closure.
487 This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
488 in TcGenDeriv.) -}
489
490 -----------------------------------------------------------------------------
491 -- getCallMethod
492 -----------------------------------------------------------------------------
493
494 {- The entry conventions depend on the type of closure being entered,
495 whether or not it has free variables, and whether we're running
496 sequentially or in parallel.
497
498 Closure Node Argument Enter
499 Characteristics Par Req'd Passing Via
500 ---------------------------------------------------------------------------
501 Unknown & no & yes & stack & node
502 Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args)
503 & slow entry (otherwise)
504 Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args)
505 0 arg, no fvs \r,\s & no & no & n/a & direct entry
506 0 arg, no fvs \u & no & yes & n/a & node
507 0 arg, fvs \r,\s,selector & no & yes & n/a & node
508 0 arg, fvs \r,\s & no & yes & n/a & direct entry
509 0 arg, fvs \u & no & yes & n/a & node
510 Unknown & yes & yes & stack & node
511 Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args)
512 & slow entry (otherwise)
513 Known fun (>1 arg), fvs & yes & yes & registers & node
514 0 arg, fvs \r,\s,selector & yes & yes & n/a & node
515 0 arg, no fvs \r,\s & yes & no & n/a & direct entry
516 0 arg, no fvs \u & yes & yes & n/a & node
517 0 arg, fvs \r,\s & yes & yes & n/a & node
518 0 arg, fvs \u & yes & yes & n/a & node
519
520 When black-holing, single-entry closures could also be entered via node
521 (rather than directly) to catch double-entry. -}
522
523 data CallMethod
524 = EnterIt -- No args, not a function
525
526 | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
527
528 | ReturnIt -- It's a value (function, unboxed value,
529 -- or constructor), so just return it.
530
531 | SlowCall -- Unknown fun, or known fun with
532 -- too few args.
533
534 | DirectEntry -- Jump directly, with args in regs
535 CLabel -- The code label
536 RepArity -- Its arity
537
538 getCallMethod :: DynFlags
539 -> Name -- Function being applied
540 -> Id -- Function Id used to chech if it can refer to
541 -- CAF's and whether the function is tail-calling
542 -- itself
543 -> LambdaFormInfo -- Its info
544 -> RepArity -- Number of available arguments
545 -> RepArity -- Number of them being void arguments
546 -> CgLoc -- Passed in from cgIdApp so that we can
547 -- handle let-no-escape bindings and self-recursive
548 -- tail calls using the same data constructor,
549 -- JumpToIt. This saves us one case branch in
550 -- cgIdApp
551 -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
552 -> CallMethod
553
554 getCallMethod dflags _ id _ n_args v_args _cg_loc
555 (Just (self_loop_id, block_id, args))
556 | gopt Opt_Loopification dflags
557 , id == self_loop_id
558 , args `lengthIs` (n_args - v_args)
559 -- If these patterns match then we know that:
560 -- * loopification optimisation is turned on
561 -- * function is performing a self-recursive call in a tail position
562 -- * number of non-void parameters of the function matches functions arity.
563 -- See Note [Self-recursive tail calls] and Note [Void arguments in
564 -- self-recursive tail calls] in StgCmmExpr for more details
565 = JumpToIt block_id args
566
567 getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
568 _self_loop_info
569 | n_args == 0 -- No args at all
570 && not (gopt Opt_SccProfilingOn dflags)
571 -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
572 = ASSERT( arity /= 0 ) ReturnIt
573 | n_args < arity = SlowCall -- Not enough args
574 | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
575
576 getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
577 = ASSERT( n_args == 0 ) ReturnIt
578
579 getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
580 = ASSERT( n_args == 0 ) ReturnIt
581 -- n_args=0 because it'd be ill-typed to apply a saturated
582 -- constructor application to anything
583
584 getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
585 n_args _v_args _cg_loc _self_loop_info
586 | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
587 = SlowCall -- We cannot just enter it [in eval/apply, the entry code
588 -- is the fast-entry code]
589
590 -- Since is_fun is False, we are *definitely* looking at a data value
591 | updatable || gopt Opt_Ticky dflags -- to catch double entry
592 {- OLD: || opt_SMP
593 I decided to remove this, because in SMP mode it doesn't matter
594 if we enter the same thunk multiple times, so the optimisation
595 of jumping directly to the entry code is still valid. --SDM
596 -}
597 = EnterIt
598
599 -- even a non-updatable selector thunk can be updated by the garbage
600 -- collector, so we must enter it. (#8817)
601 | SelectorThunk{} <- std_form_info
602 = EnterIt
603
604 -- We used to have ASSERT( n_args == 0 ), but actually it is
605 -- possible for the optimiser to generate
606 -- let bot :: Int = error Int "urk"
607 -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
608 -- This happens as a result of the case-of-error transformation
609 -- So the right thing to do is just to enter the thing
610
611 | otherwise -- Jump direct to code for single-entry thunks
612 = ASSERT( n_args == 0 )
613 DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
614 updatable) 0
615
616 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
617 = SlowCall -- might be a function
618
619 getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
620 = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
621 EnterIt -- Not a function
622
623 getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
624 _self_loop_info
625 = JumpToIt blk_id lne_regs
626
627 getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
628
629 -----------------------------------------------------------------------------
630 -- staticClosureRequired
631 -----------------------------------------------------------------------------
632
633 {- staticClosureRequired is never called (hence commented out)
634
635 SimonMar writes (Sept 07) It's an optimisation we used to apply at
636 one time, I believe, but it got lost probably in the rewrite of
637 the RTS/code generator. I left that code there to remind me to
638 look into whether it was worth doing sometime
639
640 {- Avoiding generating entries and info tables
641 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
642 At present, for every function we generate all of the following,
643 just in case. But they aren't always all needed, as noted below:
644
645 [NB1: all of this applies only to *functions*. Thunks always
646 have closure, info table, and entry code.]
647
648 [NB2: All are needed if the function is *exported*, just to play safe.]
649
650 * Fast-entry code ALWAYS NEEDED
651
652 * Slow-entry code
653 Needed iff (a) we have any un-saturated calls to the function
654 OR (b) the function is passed as an arg
655 OR (c) we're in the parallel world and the function has free vars
656 [Reason: in parallel world, we always enter functions
657 with free vars via the closure.]
658
659 * The function closure
660 Needed iff (a) we have any un-saturated calls to the function
661 OR (b) the function is passed as an arg
662 OR (c) if the function has free vars (ie not top level)
663
664 Why case (a) here? Because if the arg-satis check fails,
665 UpdatePAP stuffs a pointer to the function closure in the PAP.
666 [Could be changed; UpdatePAP could stuff in a code ptr instead,
667 but doesn't seem worth it.]
668
669 [NB: these conditions imply that we might need the closure
670 without the slow-entry code. Here's how.
671
672 f x y = let g w = ...x..y..w...
673 in
674 ...(g t)...
675
676 Here we need a closure for g which contains x and y,
677 but since the calls are all saturated we just jump to the
678 fast entry point for g, with R1 pointing to the closure for g.]
679
680
681 * Standard info table
682 Needed iff (a) we have any un-saturated calls to the function
683 OR (b) the function is passed as an arg
684 OR (c) the function has free vars (ie not top level)
685
686 NB. In the sequential world, (c) is only required so that the function closure has
687 an info table to point to, to keep the storage manager happy.
688 If (c) alone is true we could fake up an info table by choosing
689 one of a standard family of info tables, whose entry code just
690 bombs out.
691
692 [NB In the parallel world (c) is needed regardless because
693 we enter functions with free vars via the closure.]
694
695 If (c) is retained, then we'll sometimes generate an info table
696 (for storage mgr purposes) without slow-entry code. Then we need
697 to use an error label in the info table to substitute for the absent
698 slow entry code.
699 -}
700
701 staticClosureRequired
702 :: Name
703 -> StgBinderInfo
704 -> LambdaFormInfo
705 -> Bool
706 staticClosureRequired binder bndr_info
707 (LFReEntrant top_level _ _ _ _) -- It's a function
708 = ASSERT( isTopLevel top_level )
709 -- Assumption: it's a top-level, no-free-var binding
710 not (satCallsOnly bndr_info)
711
712 staticClosureRequired binder other_binder_info other_lf_info = True
713 -}
714
715 -----------------------------------------------------------------------------
716 -- Data types for closure information
717 -----------------------------------------------------------------------------
718
719
720 {- ClosureInfo: information about a binding
721
722 We make a ClosureInfo for each let binding (both top level and not),
723 but not bindings for data constructors: for those we build a CmmInfoTable
724 directly (see mkDataConInfoTable).
725
726 To a first approximation:
727 ClosureInfo = (LambdaFormInfo, CmmInfoTable)
728
729 A ClosureInfo has enough information
730 a) to construct the info table itself, and build other things
731 related to the binding (e.g. slow entry points for a function)
732 b) to allocate a closure containing that info pointer (i.e.
733 it knows the info table label)
734 -}
735
736 data ClosureInfo
737 = ClosureInfo {
738 closureName :: !Name, -- The thing bound to this closure
739 -- we don't really need this field: it's only used in generating
740 -- code for ticky and profiling, and we could pass the information
741 -- around separately, but it doesn't do much harm to keep it here.
742
743 closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
744 -- this tells us about what the closure contains: it's right-hand-side.
745
746 -- the rest is just an unpacked CmmInfoTable.
747 closureInfoLabel :: !CLabel,
748 closureSMRep :: !SMRep, -- representation used by storage mgr
749 closureProf :: !ProfilingInfo
750 }
751
752 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
753 mkCmmInfo :: ClosureInfo -> CmmInfoTable
754 mkCmmInfo ClosureInfo {..}
755 = CmmInfoTable { cit_lbl = closureInfoLabel
756 , cit_rep = closureSMRep
757 , cit_prof = closureProf
758 , cit_srt = NoC_SRT }
759
760 --------------------------------------
761 -- Building ClosureInfos
762 --------------------------------------
763
764 mkClosureInfo :: DynFlags
765 -> Bool -- Is static
766 -> Id
767 -> LambdaFormInfo
768 -> Int -> Int -- Total and pointer words
769 -> String -- String descriptor
770 -> ClosureInfo
771 mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
772 = ClosureInfo { closureName = name
773 , closureLFInfo = lf_info
774 , closureInfoLabel = info_lbl -- These three fields are
775 , closureSMRep = sm_rep -- (almost) an info table
776 , closureProf = prof } -- (we don't have an SRT yet)
777 where
778 name = idName id
779 sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
780 prof = mkProfilingInfo dflags id val_descr
781 nonptr_wds = tot_wds - ptr_wds
782
783 info_lbl = mkClosureInfoTableLabel id lf_info
784
785 --------------------------------------
786 -- Other functions over ClosureInfo
787 --------------------------------------
788
789 -- Eager blackholing is normally disabled, but can be turned on with
790 -- -feager-blackholing. When it is on, we replace the info pointer of
791 -- the thunk with stg_EAGER_BLACKHOLE_info on entry.
792
793 -- If we wanted to do eager blackholing with slop filling,
794 -- we'd need to do it at the *end* of a basic block, otherwise
795 -- we overwrite the free variables in the thunk that we still
796 -- need. We have a patch for this from Andy Cheadle, but not
797 -- incorporated yet. --SDM [6/2004]
798 --
799 -- Previously, eager blackholing was enabled when ticky-ticky
800 -- was on. But it didn't work, and it wasn't strictly necessary
801 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
802 -- is unconditionally disabled. -- krc 1/2007
803 --
804 -- Static closures are never themselves black-holed.
805
806 blackHoleOnEntry :: ClosureInfo -> Bool
807 blackHoleOnEntry cl_info
808 | isStaticRep (closureSMRep cl_info)
809 = False -- Never black-hole a static closure
810
811 | otherwise
812 = case closureLFInfo cl_info of
813 LFReEntrant {} -> False
814 LFLetNoEscape -> False
815 LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks]
816 _other -> panic "blackHoleOnEntry"
817
818 {- Note [Black-holing non-updatable thunks]
819 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
820 We must not black-hole non-updatable (single-entry) thunks otherwise
821 we run into issues like Trac #10414. Specifically:
822
823 * There is no reason to black-hole a non-updatable thunk: it should
824 not be competed for by multiple threads
825
826 * It could, conceivably, cause a space leak if we don't black-hole
827 it, if there was a live but never-followed pointer pointing to it.
828 Let's hope that doesn't happen.
829
830 * It is dangerous to black-hole a non-updatable thunk because
831 - is not updated (of course)
832 - hence, if it is black-holed and another thread tries to evaluate
833 it, that thread will block forever
834 This actually happened in Trac #10414. So we do not black-hole
835 non-updatable thunks.
836
837 * How could two threads evaluate the same non-updatable (single-entry)
838 thunk? See Reid Barton's example below.
839
840 * Only eager blackholing could possibly black-hole a non-updatable
841 thunk, because lazy black-holing only affects thunks with an
842 update frame on the stack.
843
844 Here is and example due to Reid Barton (Trac #10414):
845 x = \u [] concat [[1], []]
846 with the following definitions,
847
848 concat x = case x of
849 [] -> []
850 (:) x xs -> (++) x (concat xs)
851
852 (++) xs ys = case xs of
853 [] -> ys
854 (:) x rest -> (:) x ((++) rest ys)
855
856 Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
857 denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
858 to WHNF and calls @(++)@ the heap will contain the following thunks,
859
860 x = 1 : y
861 y = \u [] (++) [] z
862 z = \s [] concat []
863
864 Now that the stage is set, consider the follow evaluations by two racing threads
865 A and B,
866
867 1. Both threads enter @y@ before either is able to replace it with an
868 indirection
869
870 2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
871 replacing it with a black-hole
872
873 3. At some later point thread B does the same case analysis and also attempts
874 to enter @z@. However, it finds that it has been replaced with a black-hole
875 so it blocks.
876
877 4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
878 accordingly. It does *not* update @z@, however, as it is single-entry. This
879 leaves Thread B blocked forever on a black-hole which will never be
880 updated.
881
882 To avoid this sort of condition we never black-hole non-updatable thunks.
883 -}
884
885 isStaticClosure :: ClosureInfo -> Bool
886 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
887
888 closureUpdReqd :: ClosureInfo -> Bool
889 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
890
891 lfUpdatable :: LambdaFormInfo -> Bool
892 lfUpdatable (LFThunk _ _ upd _ _) = upd
893 lfUpdatable _ = False
894
895 closureSingleEntry :: ClosureInfo -> Bool
896 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
897 closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
898 closureSingleEntry _ = False
899
900 closureReEntrant :: ClosureInfo -> Bool
901 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
902 closureReEntrant _ = False
903
904 closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
905 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
906
907 lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
908 lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc)
909 lfFunInfo _ = Nothing
910
911 funTag :: DynFlags -> ClosureInfo -> DynTag
912 funTag dflags (ClosureInfo { closureLFInfo = lf_info })
913 = lfDynTag dflags lf_info
914
915 isToplevClosure :: ClosureInfo -> Bool
916 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
917 = case lf_info of
918 LFReEntrant TopLevel _ _ _ _ -> True
919 LFThunk TopLevel _ _ _ _ -> True
920 _other -> False
921
922 --------------------------------------
923 -- Label generation
924 --------------------------------------
925
926 staticClosureLabel :: ClosureInfo -> CLabel
927 staticClosureLabel = toClosureLbl . closureInfoLabel
928
929 closureSlowEntryLabel :: ClosureInfo -> CLabel
930 closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
931
932 closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
933 closureLocalEntryLabel dflags
934 | tablesNextToCode dflags = toInfoLbl . closureInfoLabel
935 | otherwise = toEntryLbl . closureInfoLabel
936
937 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
938 mkClosureInfoTableLabel id lf_info
939 = case lf_info of
940 LFThunk _ _ upd_flag (SelectorThunk offset) _
941 -> mkSelectorInfoLabel upd_flag offset
942
943 LFThunk _ _ upd_flag (ApThunk arity) _
944 -> mkApInfoTableLabel upd_flag arity
945
946 LFThunk{} -> std_mk_lbl name cafs
947 LFReEntrant{} -> std_mk_lbl name cafs
948 _other -> panic "closureInfoTableLabel"
949
950 where
951 name = idName id
952
953 std_mk_lbl | is_local = mkLocalInfoTableLabel
954 | otherwise = mkInfoTableLabel
955
956 cafs = idCafInfo id
957 is_local = isDataConWorkId id
958 -- Make the _info pointer for the implicit datacon worker
959 -- binding local. The reason we can do this is that importing
960 -- code always either uses the _closure or _con_info. By the
961 -- invariants in CorePrep anything else gets eta expanded.
962
963
964 thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
965 -- thunkEntryLabel is a local help function, not exported. It's used from
966 -- getCallMethod.
967 thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
968 = enterApLabel dflags upd_flag arity
969 thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
970 = enterSelectorLabel dflags upd_flag offset
971 thunkEntryLabel dflags thunk_id c _ _
972 = enterIdLabel dflags thunk_id c
973
974 enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
975 enterApLabel dflags is_updatable arity
976 | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
977 | otherwise = mkApEntryLabel is_updatable arity
978
979 enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
980 enterSelectorLabel dflags upd_flag offset
981 | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
982 | otherwise = mkSelectorEntryLabel upd_flag offset
983
984 enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
985 enterIdLabel dflags id c
986 | tablesNextToCode dflags = mkInfoTableLabel id c
987 | otherwise = mkEntryLabel id c
988
989
990 --------------------------------------
991 -- Profiling
992 --------------------------------------
993
994 -- Profiling requires two pieces of information to be determined for
995 -- each closure's info table --- description and type.
996
997 -- The description is stored directly in the @CClosureInfoTable@ when the
998 -- info table is built.
999
1000 -- The type is determined from the type information stored with the @Id@
1001 -- in the closure info using @closureTypeDescr@.
1002
1003 mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
1004 mkProfilingInfo dflags id val_descr
1005 | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
1006 | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
1007 where
1008 ty_descr_w8 = stringToWord8s (getTyDescription (idType id))
1009 val_descr_w8 = stringToWord8s val_descr
1010
1011 getTyDescription :: Type -> String
1012 getTyDescription ty
1013 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1014 case tau_ty of
1015 TyVarTy _ -> "*"
1016 AppTy fun _ -> getTyDescription fun
1017 TyConApp tycon _ -> getOccString tycon
1018 FunTy _ res -> '-' : '>' : fun_result res
1019 ForAllTy _ ty -> getTyDescription ty
1020 LitTy n -> getTyLitDescription n
1021 CastTy ty _ -> getTyDescription ty
1022 CoercionTy co -> pprPanic "getTyDescription" (ppr co)
1023 }
1024 where
1025 fun_result (FunTy _ res) = '>' : fun_result res
1026 fun_result other = getTyDescription other
1027
1028 getTyLitDescription :: TyLit -> String
1029 getTyLitDescription l =
1030 case l of
1031 NumTyLit n -> show n
1032 StrTyLit n -> show n
1033
1034 --------------------------------------
1035 -- CmmInfoTable-related things
1036 --------------------------------------
1037
1038 mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
1039 mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
1040 = CmmInfoTable { cit_lbl = info_lbl
1041 , cit_rep = sm_rep
1042 , cit_prof = prof
1043 , cit_srt = NoC_SRT }
1044 where
1045 name = dataConName data_con
1046 info_lbl = mkConInfoTableLabel name NoCafRefs
1047 sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
1048 cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
1049 -- We keep the *zero-indexed* tag in the srt_len field
1050 -- of the info table of a data constructor.
1051
1052 prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
1053 | otherwise = ProfilingInfo ty_descr val_descr
1054
1055 ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
1056 val_descr = stringToWord8s $ occNameString $ getOccName data_con
1057
1058 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
1059 -- want to allocate the black hole on entry to a CAF.
1060
1061 cafBlackHoleInfoTable :: CmmInfoTable
1062 cafBlackHoleInfoTable
1063 = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel
1064 , cit_rep = blackHoleRep
1065 , cit_prof = NoProfilingInfo
1066 , cit_srt = NoC_SRT }
1067
1068 indStaticInfoTable :: CmmInfoTable
1069 indStaticInfoTable
1070 = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel
1071 , cit_rep = indStaticRep
1072 , cit_prof = NoProfilingInfo
1073 , cit_srt = NoC_SRT }
1074
1075 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
1076 -- A static closure needs a link field to aid the GC when traversing
1077 -- the static closure graph. But it only needs such a field if either
1078 -- a) it has an SRT
1079 -- b) it's a constructor with one or more pointer fields
1080 -- In case (b), the constructor's fields themselves play the role
1081 -- of the SRT.
1082 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
1083 | isConRep smrep = not (isStaticNoCafCon smrep)
1084 | otherwise = has_srt -- needsSRT (cit_srt info_tbl)