Add 'hadrian/' from commit '45f3bff7016a2a0cd9a5455a882ced984655e90b'
[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 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 isLFThunk :: LambdaFormInfo -> Bool
392 isLFThunk (LFThunk {}) = True
393 isLFThunk _ = False
394
395 isLFReEntrant :: LambdaFormInfo -> Bool
396 isLFReEntrant (LFReEntrant {}) = True
397 isLFReEntrant _ = False
398
399 -----------------------------------------------------------------------------
400 -- Choosing SM reps
401 -----------------------------------------------------------------------------
402
403 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
404 lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
405 lfClosureType (LFCon con) = Constr (dataConTagZ con)
406 (dataConIdentity con)
407 lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
408 lfClosureType _ = panic "lfClosureType"
409
410 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
411 thunkClosureType (SelectorThunk off) = ThunkSelector off
412 thunkClosureType _ = Thunk
413
414 -- We *do* get non-updatable top-level thunks sometimes. eg. f = g
415 -- gets compiled to a jump to g (if g has non-zero arity), instead of
416 -- messing around with update frames and PAPs. We set the closure type
417 -- to FUN_STATIC in this case.
418
419 -----------------------------------------------------------------------------
420 -- nodeMustPointToIt
421 -----------------------------------------------------------------------------
422
423 nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
424 -- If nodeMustPointToIt is true, then the entry convention for
425 -- this closure has R1 (the "Node" register) pointing to the
426 -- closure itself --- the "self" argument
427
428 nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
429 = not no_fvs -- Certainly if it has fvs we need to point to it
430 || isNotTopLevel top -- See Note [GC recovery]
431 -- For lex_profiling we also access the cost centre for a
432 -- non-inherited (i.e. non-top-level) function.
433 -- The isNotTopLevel test above ensures this is ok.
434
435 nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
436 = not no_fvs -- Self parameter
437 || isNotTopLevel top -- Note [GC recovery]
438 || updatable -- Need to push update frame
439 || gopt Opt_SccProfilingOn dflags
440 -- For the non-updatable (single-entry case):
441 --
442 -- True if has fvs (in which case we need access to them, and we
443 -- should black-hole it)
444 -- or profiling (in which case we need to recover the cost centre
445 -- from inside it) ToDo: do we need this even for
446 -- top-level thunks? If not,
447 -- isNotTopLevel subsumes this
448
449 nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk
450 = True
451
452 nodeMustPointToIt _ (LFCon _) = True
453
454 -- Strictly speaking, the above two don't need Node to point
455 -- to it if the arity = 0. But this is a *really* unlikely
456 -- situation. If we know it's nil (say) and we are entering
457 -- it. Eg: let x = [] in x then we will certainly have inlined
458 -- x, since nil is a simple atom. So we gain little by not
459 -- having Node point to known zero-arity things. On the other
460 -- hand, we do lose something; Patrick's code for figuring out
461 -- when something has been updated but not entered relies on
462 -- having Node point to the result of an update. SLPJ
463 -- 27/11/92.
464
465 nodeMustPointToIt _ (LFUnknown _) = True
466 nodeMustPointToIt _ LFUnlifted = False
467 nodeMustPointToIt _ LFLetNoEscape = False
468
469 {- Note [GC recovery]
470 ~~~~~~~~~~~~~~~~~~~~~
471 If we a have a local let-binding (function or thunk)
472 let f = <body> in ...
473 AND <body> allocates, then the heap-overflow check needs to know how
474 to re-start the evaluation. It uses the "self" pointer to do this.
475 So even if there are no free variables in <body>, we still make
476 nodeMustPointToIt be True for non-top-level bindings.
477
478 Why do any such bindings exist? After all, let-floating should have
479 floated them out. Well, a clever optimiser might leave one there to
480 avoid a space leak, deliberately recomputing a thunk. Also (and this
481 really does happen occasionally) let-floating may make a function f smaller
482 so it can be inlined, so now (f True) may generate a local no-fv closure.
483 This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
484 in TcGenDeriv.) -}
485
486 -----------------------------------------------------------------------------
487 -- getCallMethod
488 -----------------------------------------------------------------------------
489
490 {- The entry conventions depend on the type of closure being entered,
491 whether or not it has free variables, and whether we're running
492 sequentially or in parallel.
493
494 Closure Node Argument Enter
495 Characteristics Par Req'd Passing Via
496 ---------------------------------------------------------------------------
497 Unknown & no & yes & stack & node
498 Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args)
499 & slow entry (otherwise)
500 Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args)
501 0 arg, no fvs \r,\s & no & no & n/a & direct entry
502 0 arg, no fvs \u & no & yes & n/a & node
503 0 arg, fvs \r,\s,selector & no & yes & n/a & node
504 0 arg, fvs \r,\s & no & yes & n/a & direct entry
505 0 arg, fvs \u & no & yes & n/a & node
506 Unknown & yes & yes & stack & node
507 Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args)
508 & slow entry (otherwise)
509 Known fun (>1 arg), fvs & yes & yes & registers & node
510 0 arg, fvs \r,\s,selector & yes & yes & n/a & node
511 0 arg, no fvs \r,\s & yes & no & n/a & direct entry
512 0 arg, no fvs \u & yes & yes & n/a & node
513 0 arg, fvs \r,\s & yes & yes & n/a & node
514 0 arg, fvs \u & yes & yes & n/a & node
515
516 When black-holing, single-entry closures could also be entered via node
517 (rather than directly) to catch double-entry. -}
518
519 data CallMethod
520 = EnterIt -- No args, not a function
521
522 | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
523
524 | ReturnIt -- It's a value (function, unboxed value,
525 -- or constructor), so just return it.
526
527 | SlowCall -- Unknown fun, or known fun with
528 -- too few args.
529
530 | DirectEntry -- Jump directly, with args in regs
531 CLabel -- The code label
532 RepArity -- Its arity
533
534 getCallMethod :: DynFlags
535 -> Name -- Function being applied
536 -> Id -- Function Id used to chech if it can refer to
537 -- CAF's and whether the function is tail-calling
538 -- itself
539 -> LambdaFormInfo -- Its info
540 -> RepArity -- Number of available arguments
541 -> RepArity -- Number of them being void arguments
542 -> CgLoc -- Passed in from cgIdApp so that we can
543 -- handle let-no-escape bindings and self-recursive
544 -- tail calls using the same data constructor,
545 -- JumpToIt. This saves us one case branch in
546 -- cgIdApp
547 -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
548 -> CallMethod
549
550 getCallMethod dflags _ id _ n_args v_args _cg_loc
551 (Just (self_loop_id, block_id, args))
552 | gopt Opt_Loopification dflags
553 , id == self_loop_id
554 , args `lengthIs` (n_args - v_args)
555 -- If these patterns match then we know that:
556 -- * loopification optimisation is turned on
557 -- * function is performing a self-recursive call in a tail position
558 -- * number of non-void parameters of the function matches functions arity.
559 -- See Note [Self-recursive tail calls] and Note [Void arguments in
560 -- self-recursive tail calls] in StgCmmExpr for more details
561 = JumpToIt block_id args
562
563 getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
564 _self_loop_info
565 | n_args == 0 -- No args at all
566 && not (gopt Opt_SccProfilingOn dflags)
567 -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
568 = ASSERT( arity /= 0 ) ReturnIt
569 | n_args < arity = SlowCall -- Not enough args
570 | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
571
572 getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
573 = ASSERT( n_args == 0 ) ReturnIt
574
575 getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
576 = ASSERT( n_args == 0 ) ReturnIt
577 -- n_args=0 because it'd be ill-typed to apply a saturated
578 -- constructor application to anything
579
580 getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
581 n_args _v_args _cg_loc _self_loop_info
582 | is_fun -- it *might* be a function, so we must "call" it (which is always safe)
583 = SlowCall -- We cannot just enter it [in eval/apply, the entry code
584 -- is the fast-entry code]
585
586 -- Since is_fun is False, we are *definitely* looking at a data value
587 | updatable || gopt Opt_Ticky dflags -- to catch double entry
588 {- OLD: || opt_SMP
589 I decided to remove this, because in SMP mode it doesn't matter
590 if we enter the same thunk multiple times, so the optimisation
591 of jumping directly to the entry code is still valid. --SDM
592 -}
593 = EnterIt
594
595 -- even a non-updatable selector thunk can be updated by the garbage
596 -- collector, so we must enter it. (#8817)
597 | SelectorThunk{} <- std_form_info
598 = EnterIt
599
600 -- We used to have ASSERT( n_args == 0 ), but actually it is
601 -- possible for the optimiser to generate
602 -- let bot :: Int = error Int "urk"
603 -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
604 -- This happens as a result of the case-of-error transformation
605 -- So the right thing to do is just to enter the thing
606
607 | otherwise -- Jump direct to code for single-entry thunks
608 = ASSERT( n_args == 0 )
609 DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
610 updatable) 0
611
612 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
613 = SlowCall -- might be a function
614
615 getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
616 = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
617 EnterIt -- Not a function
618
619 getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
620 _self_loop_info
621 = JumpToIt blk_id lne_regs
622
623 getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
624
625 -----------------------------------------------------------------------------
626 -- staticClosureRequired
627 -----------------------------------------------------------------------------
628
629 {- staticClosureRequired is never called (hence commented out)
630
631 SimonMar writes (Sept 07) It's an optimisation we used to apply at
632 one time, I believe, but it got lost probably in the rewrite of
633 the RTS/code generator. I left that code there to remind me to
634 look into whether it was worth doing sometime
635
636 {- Avoiding generating entries and info tables
637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
638 At present, for every function we generate all of the following,
639 just in case. But they aren't always all needed, as noted below:
640
641 [NB1: all of this applies only to *functions*. Thunks always
642 have closure, info table, and entry code.]
643
644 [NB2: All are needed if the function is *exported*, just to play safe.]
645
646 * Fast-entry code ALWAYS NEEDED
647
648 * Slow-entry code
649 Needed iff (a) we have any un-saturated calls to the function
650 OR (b) the function is passed as an arg
651 OR (c) we're in the parallel world and the function has free vars
652 [Reason: in parallel world, we always enter functions
653 with free vars via the closure.]
654
655 * The function closure
656 Needed iff (a) we have any un-saturated calls to the function
657 OR (b) the function is passed as an arg
658 OR (c) if the function has free vars (ie not top level)
659
660 Why case (a) here? Because if the arg-satis check fails,
661 UpdatePAP stuffs a pointer to the function closure in the PAP.
662 [Could be changed; UpdatePAP could stuff in a code ptr instead,
663 but doesn't seem worth it.]
664
665 [NB: these conditions imply that we might need the closure
666 without the slow-entry code. Here's how.
667
668 f x y = let g w = ...x..y..w...
669 in
670 ...(g t)...
671
672 Here we need a closure for g which contains x and y,
673 but since the calls are all saturated we just jump to the
674 fast entry point for g, with R1 pointing to the closure for g.]
675
676
677 * Standard info table
678 Needed iff (a) we have any un-saturated calls to the function
679 OR (b) the function is passed as an arg
680 OR (c) the function has free vars (ie not top level)
681
682 NB. In the sequential world, (c) is only required so that the function closure has
683 an info table to point to, to keep the storage manager happy.
684 If (c) alone is true we could fake up an info table by choosing
685 one of a standard family of info tables, whose entry code just
686 bombs out.
687
688 [NB In the parallel world (c) is needed regardless because
689 we enter functions with free vars via the closure.]
690
691 If (c) is retained, then we'll sometimes generate an info table
692 (for storage mgr purposes) without slow-entry code. Then we need
693 to use an error label in the info table to substitute for the absent
694 slow entry code.
695 -}
696
697 staticClosureRequired
698 :: Name
699 -> StgBinderInfo
700 -> LambdaFormInfo
701 -> Bool
702 staticClosureRequired binder bndr_info
703 (LFReEntrant top_level _ _ _ _) -- It's a function
704 = ASSERT( isTopLevel top_level )
705 -- Assumption: it's a top-level, no-free-var binding
706 not (satCallsOnly bndr_info)
707
708 staticClosureRequired binder other_binder_info other_lf_info = True
709 -}
710
711 -----------------------------------------------------------------------------
712 -- Data types for closure information
713 -----------------------------------------------------------------------------
714
715
716 {- ClosureInfo: information about a binding
717
718 We make a ClosureInfo for each let binding (both top level and not),
719 but not bindings for data constructors: for those we build a CmmInfoTable
720 directly (see mkDataConInfoTable).
721
722 To a first approximation:
723 ClosureInfo = (LambdaFormInfo, CmmInfoTable)
724
725 A ClosureInfo has enough information
726 a) to construct the info table itself, and build other things
727 related to the binding (e.g. slow entry points for a function)
728 b) to allocate a closure containing that info pointer (i.e.
729 it knows the info table label)
730 -}
731
732 data ClosureInfo
733 = ClosureInfo {
734 closureName :: !Name, -- The thing bound to this closure
735 -- we don't really need this field: it's only used in generating
736 -- code for ticky and profiling, and we could pass the information
737 -- around separately, but it doesn't do much harm to keep it here.
738
739 closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
740 -- this tells us about what the closure contains: it's right-hand-side.
741
742 -- the rest is just an unpacked CmmInfoTable.
743 closureInfoLabel :: !CLabel,
744 closureSMRep :: !SMRep, -- representation used by storage mgr
745 closureProf :: !ProfilingInfo
746 }
747
748 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
749 mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
750 mkCmmInfo ClosureInfo {..} id ccs
751 = CmmInfoTable { cit_lbl = closureInfoLabel
752 , cit_rep = closureSMRep
753 , cit_prof = closureProf
754 , cit_srt = Nothing
755 , cit_clo = if isStaticRep closureSMRep
756 then Just (id,ccs)
757 else Nothing }
758
759 --------------------------------------
760 -- Building ClosureInfos
761 --------------------------------------
762
763 mkClosureInfo :: DynFlags
764 -> Bool -- Is static
765 -> Id
766 -> LambdaFormInfo
767 -> Int -> Int -- Total and pointer words
768 -> String -- String descriptor
769 -> ClosureInfo
770 mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
771 = ClosureInfo { closureName = name
772 , closureLFInfo = lf_info
773 , closureInfoLabel = info_lbl -- These three fields are
774 , closureSMRep = sm_rep -- (almost) an info table
775 , closureProf = prof } -- (we don't have an SRT yet)
776 where
777 name = idName id
778 sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
779 prof = mkProfilingInfo dflags id val_descr
780 nonptr_wds = tot_wds - ptr_wds
781
782 info_lbl = mkClosureInfoTableLabel id lf_info
783
784 --------------------------------------
785 -- Other functions over ClosureInfo
786 --------------------------------------
787
788 -- Eager blackholing is normally disabled, but can be turned on with
789 -- -feager-blackholing. When it is on, we replace the info pointer of
790 -- the thunk with stg_EAGER_BLACKHOLE_info on entry.
791
792 -- If we wanted to do eager blackholing with slop filling,
793 -- we'd need to do it at the *end* of a basic block, otherwise
794 -- we overwrite the free variables in the thunk that we still
795 -- need. We have a patch for this from Andy Cheadle, but not
796 -- incorporated yet. --SDM [6/2004]
797 --
798 -- Previously, eager blackholing was enabled when ticky-ticky
799 -- was on. But it didn't work, and it wasn't strictly necessary
800 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
801 -- is unconditionally disabled. -- krc 1/2007
802 --
803 -- Static closures are never themselves black-holed.
804
805 blackHoleOnEntry :: ClosureInfo -> Bool
806 blackHoleOnEntry cl_info
807 | isStaticRep (closureSMRep cl_info)
808 = False -- Never black-hole a static closure
809
810 | otherwise
811 = case closureLFInfo cl_info of
812 LFReEntrant {} -> False
813 LFLetNoEscape -> False
814 LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks]
815 _other -> panic "blackHoleOnEntry"
816
817 {- Note [Black-holing non-updatable thunks]
818 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
819 We must not black-hole non-updatable (single-entry) thunks otherwise
820 we run into issues like Trac #10414. Specifically:
821
822 * There is no reason to black-hole a non-updatable thunk: it should
823 not be competed for by multiple threads
824
825 * It could, conceivably, cause a space leak if we don't black-hole
826 it, if there was a live but never-followed pointer pointing to it.
827 Let's hope that doesn't happen.
828
829 * It is dangerous to black-hole a non-updatable thunk because
830 - is not updated (of course)
831 - hence, if it is black-holed and another thread tries to evaluate
832 it, that thread will block forever
833 This actually happened in Trac #10414. So we do not black-hole
834 non-updatable thunks.
835
836 * How could two threads evaluate the same non-updatable (single-entry)
837 thunk? See Reid Barton's example below.
838
839 * Only eager blackholing could possibly black-hole a non-updatable
840 thunk, because lazy black-holing only affects thunks with an
841 update frame on the stack.
842
843 Here is and example due to Reid Barton (Trac #10414):
844 x = \u [] concat [[1], []]
845 with the following definitions,
846
847 concat x = case x of
848 [] -> []
849 (:) x xs -> (++) x (concat xs)
850
851 (++) xs ys = case xs of
852 [] -> ys
853 (:) x rest -> (:) x ((++) rest ys)
854
855 Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
856 denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
857 to WHNF and calls @(++)@ the heap will contain the following thunks,
858
859 x = 1 : y
860 y = \u [] (++) [] z
861 z = \s [] concat []
862
863 Now that the stage is set, consider the follow evaluations by two racing threads
864 A and B,
865
866 1. Both threads enter @y@ before either is able to replace it with an
867 indirection
868
869 2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
870 replacing it with a black-hole
871
872 3. At some later point thread B does the same case analysis and also attempts
873 to enter @z@. However, it finds that it has been replaced with a black-hole
874 so it blocks.
875
876 4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
877 accordingly. It does *not* update @z@, however, as it is single-entry. This
878 leaves Thread B blocked forever on a black-hole which will never be
879 updated.
880
881 To avoid this sort of condition we never black-hole non-updatable thunks.
882 -}
883
884 isStaticClosure :: ClosureInfo -> Bool
885 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
886
887 closureUpdReqd :: ClosureInfo -> Bool
888 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
889
890 lfUpdatable :: LambdaFormInfo -> Bool
891 lfUpdatable (LFThunk _ _ upd _ _) = upd
892 lfUpdatable _ = False
893
894 closureSingleEntry :: ClosureInfo -> Bool
895 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
896 closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
897 closureSingleEntry _ = False
898
899 closureReEntrant :: ClosureInfo -> Bool
900 closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
901 closureReEntrant _ = False
902
903 closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
904 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
905
906 lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
907 lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc)
908 lfFunInfo _ = Nothing
909
910 funTag :: DynFlags -> ClosureInfo -> DynTag
911 funTag dflags (ClosureInfo { closureLFInfo = lf_info })
912 = lfDynTag dflags lf_info
913
914 isToplevClosure :: ClosureInfo -> Bool
915 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
916 = case lf_info of
917 LFReEntrant TopLevel _ _ _ _ -> True
918 LFThunk TopLevel _ _ _ _ -> True
919 _other -> False
920
921 --------------------------------------
922 -- Label generation
923 --------------------------------------
924
925 staticClosureLabel :: ClosureInfo -> CLabel
926 staticClosureLabel = toClosureLbl . closureInfoLabel
927
928 closureSlowEntryLabel :: ClosureInfo -> CLabel
929 closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
930
931 closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
932 closureLocalEntryLabel dflags
933 | tablesNextToCode dflags = toInfoLbl . closureInfoLabel
934 | otherwise = toEntryLbl . closureInfoLabel
935
936 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
937 mkClosureInfoTableLabel id lf_info
938 = case lf_info of
939 LFThunk _ _ upd_flag (SelectorThunk offset) _
940 -> mkSelectorInfoLabel upd_flag offset
941
942 LFThunk _ _ upd_flag (ApThunk arity) _
943 -> mkApInfoTableLabel upd_flag arity
944
945 LFThunk{} -> std_mk_lbl name cafs
946 LFReEntrant{} -> std_mk_lbl name cafs
947 _other -> panic "closureInfoTableLabel"
948
949 where
950 name = idName id
951
952 std_mk_lbl | is_local = mkLocalInfoTableLabel
953 | otherwise = mkInfoTableLabel
954
955 cafs = idCafInfo id
956 is_local = isDataConWorkId id
957 -- Make the _info pointer for the implicit datacon worker
958 -- binding local. The reason we can do this is that importing
959 -- code always either uses the _closure or _con_info. By the
960 -- invariants in CorePrep anything else gets eta expanded.
961
962
963 thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
964 -- thunkEntryLabel is a local help function, not exported. It's used from
965 -- getCallMethod.
966 thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
967 = enterApLabel dflags upd_flag arity
968 thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
969 = enterSelectorLabel dflags upd_flag offset
970 thunkEntryLabel dflags thunk_id c _ _
971 = enterIdLabel dflags thunk_id c
972
973 enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
974 enterApLabel dflags is_updatable arity
975 | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
976 | otherwise = mkApEntryLabel is_updatable arity
977
978 enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
979 enterSelectorLabel dflags upd_flag offset
980 | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
981 | otherwise = mkSelectorEntryLabel upd_flag offset
982
983 enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
984 enterIdLabel dflags id c
985 | tablesNextToCode dflags = mkInfoTableLabel id c
986 | otherwise = mkEntryLabel id c
987
988
989 --------------------------------------
990 -- Profiling
991 --------------------------------------
992
993 -- Profiling requires two pieces of information to be determined for
994 -- each closure's info table --- description and type.
995
996 -- The description is stored directly in the @CClosureInfoTable@ when the
997 -- info table is built.
998
999 -- The type is determined from the type information stored with the @Id@
1000 -- in the closure info using @closureTypeDescr@.
1001
1002 mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
1003 mkProfilingInfo dflags id val_descr
1004 | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
1005 | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
1006 where
1007 ty_descr_w8 = stringToWord8s (getTyDescription (idType id))
1008 val_descr_w8 = stringToWord8s val_descr
1009
1010 getTyDescription :: Type -> String
1011 getTyDescription ty
1012 = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
1013 case tau_ty of
1014 TyVarTy _ -> "*"
1015 AppTy fun _ -> getTyDescription fun
1016 TyConApp tycon _ -> getOccString tycon
1017 FunTy _ res -> '-' : '>' : fun_result res
1018 ForAllTy _ ty -> getTyDescription ty
1019 LitTy n -> getTyLitDescription n
1020 CastTy ty _ -> getTyDescription ty
1021 CoercionTy co -> pprPanic "getTyDescription" (ppr co)
1022 }
1023 where
1024 fun_result (FunTy _ res) = '>' : fun_result res
1025 fun_result other = getTyDescription other
1026
1027 getTyLitDescription :: TyLit -> String
1028 getTyLitDescription l =
1029 case l of
1030 NumTyLit n -> show n
1031 StrTyLit n -> show n
1032
1033 --------------------------------------
1034 -- CmmInfoTable-related things
1035 --------------------------------------
1036
1037 mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
1038 mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
1039 = CmmInfoTable { cit_lbl = info_lbl
1040 , cit_rep = sm_rep
1041 , cit_prof = prof
1042 , cit_srt = Nothing
1043 , cit_clo = Nothing }
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 = Nothing
1067 , cit_clo = Nothing }
1068
1069 indStaticInfoTable :: CmmInfoTable
1070 indStaticInfoTable
1071 = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel
1072 , cit_rep = indStaticRep
1073 , cit_prof = NoProfilingInfo
1074 , cit_srt = Nothing
1075 , cit_clo = Nothing }
1076
1077 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
1078 -- A static closure needs a link field to aid the GC when traversing
1079 -- the static closure graph. But it only needs such a field if either
1080 -- a) it has an SRT
1081 -- b) it's a constructor with one or more pointer fields
1082 -- In case (b), the constructor's fields themselves play the role
1083 -- of the SRT.
1084 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
1085 | isConRep smrep = not (isStaticNoCafCon smrep)
1086 | otherwise = has_srt