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