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