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