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