never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE CPP #-}
3
4 -----------------------------------------------------------------------------
5 --
6 -- Building info tables.
7 --
8 -- (c) The University of Glasgow 2004-2006
9 --
10 -----------------------------------------------------------------------------
11
12 module GHC.StgToCmm.Layout (
13 mkArgDescr,
14 emitCall, emitReturn, adjustHpBackwards,
15
16 emitClosureProcAndInfoTable,
17 emitClosureAndInfoTable,
18
19 slowCall, directCall,
20
21 FieldOffOrPadding(..),
22 ClosureHeader(..),
23 mkVirtHeapOffsets,
24 mkVirtHeapOffsetsWithPadding,
25 mkVirtConstrOffsets,
26 mkVirtConstrSizes,
27 getHpRelOffset,
28
29 ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
30 getArgAmode, getNonVoidArgAmodes
31 ) where
32
33
34 import GHC.Prelude hiding ((<*>))
35
36 import GHC.Driver.Session
37 import GHC.Driver.Ppr
38
39 import GHC.StgToCmm.Closure
40 import GHC.StgToCmm.Env
41 import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )
42 import GHC.StgToCmm.Ticky
43 import GHC.StgToCmm.Monad
44 import GHC.StgToCmm.Lit
45 import GHC.StgToCmm.Utils
46
47 import GHC.Cmm.Graph
48 import GHC.Runtime.Heap.Layout
49 import GHC.Cmm.BlockId
50 import GHC.Cmm
51 import GHC.Cmm.Utils
52 import GHC.Cmm.Info
53 import GHC.Cmm.CLabel
54 import GHC.Stg.Syntax
55 import GHC.Types.Id
56 import GHC.Core.TyCon ( PrimRep(..), primRepSizeB )
57 import GHC.Types.Basic ( RepArity )
58 import GHC.Platform
59 import GHC.Platform.Profile
60 import GHC.Unit
61
62 import GHC.Utils.Misc
63 import Data.List (mapAccumL, partition)
64 import GHC.Utils.Outputable
65 import GHC.Utils.Panic
66 import GHC.Utils.Panic.Plain
67 import GHC.Utils.Constants (debugIsOn)
68 import GHC.Data.FastString
69 import Control.Monad
70
71 ------------------------------------------------------------------------
72 -- Call and return sequences
73 ------------------------------------------------------------------------
74
75 -- | Return multiple values to the sequel
76 --
77 -- If the sequel is @Return@
78 --
79 -- > return (x,y)
80 --
81 -- If the sequel is @AssignTo [p,q]@
82 --
83 -- > p=x; q=y;
84 --
85 emitReturn :: [CmmExpr] -> FCode ReturnKind
86 emitReturn results
87 = do { profile <- getProfile
88 ; platform <- getPlatform
89 ; sequel <- getSequel
90 ; updfr_off <- getUpdFrameOff
91 ; case sequel of
92 Return ->
93 do { adjustHpBackwards
94 ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)
95 ; emit (mkReturn profile (entryCode platform e) results updfr_off)
96 }
97 AssignTo regs adjust ->
98 do { when adjust adjustHpBackwards
99 ; emitMultiAssign regs results }
100 ; return AssignedDirectly
101 }
102
103
104 -- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
105 -- using the call/return convention @conv@, passing @args@, and
106 -- returning the results to the current sequel.
107 --
108 emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
109 emitCall convs fun args
110 = emitCallWithExtraStack convs fun args noExtraStack
111
112
113 -- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
114 -- entry-code of @fun@, using the call/return convention @conv@,
115 -- passing @args@, pushing some extra stack frames described by
116 -- @stack@, and returning the results to the current sequel.
117 --
118 emitCallWithExtraStack
119 :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
120 -> [CmmExpr] -> FCode ReturnKind
121 emitCallWithExtraStack (callConv, retConv) fun args extra_stack
122 = do { profile <- getProfile
123 ; adjustHpBackwards
124 ; sequel <- getSequel
125 ; updfr_off <- getUpdFrameOff
126 ; case sequel of
127 Return -> do
128 emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack
129 return AssignedDirectly
130 AssignTo res_regs _ -> do
131 k <- newBlockId
132 let area = Young k
133 (off, _, copyin) = copyInOflow profile retConv area res_regs []
134 copyout = mkCallReturnsTo profile fun callConv args k off updfr_off
135 extra_stack
136 tscope <- getTickScope
137 emit (copyout <*> mkLabel k tscope <*> copyin)
138 return (ReturnedTo k off)
139 }
140
141
142 adjustHpBackwards :: FCode ()
143 -- This function adjusts the heap pointer just before a tail call or
144 -- return. At a call or return, the virtual heap pointer may be less
145 -- than the real Hp, because the latter was advanced to deal with
146 -- the worst-case branch of the code, and we may be in a better-case
147 -- branch. In that case, move the real Hp *back* and retract some
148 -- ticky allocation count.
149 --
150 -- It *does not* deal with high-water-mark adjustment. That's done by
151 -- functions which allocate heap.
152 adjustHpBackwards
153 = do { hp_usg <- getHpUsage
154 ; let rHp = realHp hp_usg
155 vHp = virtHp hp_usg
156 adjust_words = vHp -rHp
157 ; new_hp <- getHpRelOffset vHp
158
159 ; emit (if adjust_words == 0
160 then mkNop
161 else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
162
163 ; tickyAllocHeap False adjust_words -- ...ditto
164
165 ; setRealHp vHp
166 }
167
168
169 -------------------------------------------------------------------------
170 -- Making calls: directCall and slowCall
171 -------------------------------------------------------------------------
172
173 -- General plan is:
174 -- - we'll make *one* fast call, either to the function itself
175 -- (directCall) or to stg_ap_<pat>_fast (slowCall)
176 -- Any left-over arguments will be pushed on the stack,
177 --
178 -- e.g. Sp[old+8] = arg1
179 -- Sp[old+16] = arg2
180 -- Sp[old+32] = stg_ap_pp_info
181 -- R2 = arg3
182 -- R3 = arg4
183 -- call f() return to Nothing updfr_off: 32
184
185
186 directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
187 -- (directCall f n args)
188 -- calls f(arg1, ..., argn), and applies the result to the remaining args
189 -- The function f has arity n, and there are guaranteed at least n args
190 -- Both arity and args include void args
191 directCall conv lbl arity stg_args
192 = do { argreps <- getArgRepsAmodes stg_args
193 ; direct_call "directCall" conv lbl arity argreps }
194
195
196 slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
197 -- (slowCall fun args) applies fun to args, returning the results to Sequel
198 slowCall fun stg_args
199 = do dflags <- getDynFlags
200 profile <- getProfile
201 let platform = profilePlatform profile
202 argsreps <- getArgRepsAmodes stg_args
203 let (rts_fun, arity) = slowCallPattern (map fst argsreps)
204
205 (r, slow_code) <- getCodeR $ do
206 r <- direct_call "slow_call" NativeNodeCall
207 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
208 emitComment $ mkFastString ("slow_call for " ++
209 showSDoc dflags (pdoc platform fun) ++
210 " with pat " ++ unpackFS rts_fun)
211 return r
212
213 -- Note [avoid intermediate PAPs]
214 let n_args = length stg_args
215 if n_args > arity && optLevel dflags >= 2
216 then do
217 ptr_opts <- getPtrOpts
218 funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
219 fun_iptr <- (CmmReg . CmmLocal) `fmap`
220 assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv))
221
222 -- ToDo: we could do slightly better here by reusing the
223 -- continuation from the slow call, which we have in r.
224 -- Also we'd like to push the continuation on the stack
225 -- before the branch, so that we only get one copy of the
226 -- code that saves all the live variables across the
227 -- call, but that might need some improvements to the
228 -- special case in the stack layout code to handle this
229 -- (see Note [diamond proc point]).
230
231 fast_code <- getCode $
232 emitCall (NativeNodeCall, NativeReturn)
233 (entryCode platform fun_iptr)
234 (nonVArgs ((P,Just funv):argsreps))
235
236 slow_lbl <- newBlockId
237 fast_lbl <- newBlockId
238 is_tagged_lbl <- newBlockId
239 end_lbl <- newBlockId
240
241 let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr)
242 (mkIntExpr platform n_args)
243
244 tscope <- getTickScope
245 emit (mkCbranch (cmmIsTagged platform funv)
246 is_tagged_lbl slow_lbl (Just True)
247 <*> mkLabel is_tagged_lbl tscope
248 <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
249 <*> mkLabel fast_lbl tscope
250 <*> fast_code
251 <*> mkBranch end_lbl
252 <*> mkLabel slow_lbl tscope
253 <*> slow_code
254 <*> mkLabel end_lbl tscope)
255 return r
256
257 else do
258 emit slow_code
259 return r
260
261
262 -- Note [avoid intermediate PAPs]
263 --
264 -- A slow call which needs multiple generic apply patterns will be
265 -- almost guaranteed to create one or more intermediate PAPs when
266 -- applied to a function that takes the correct number of arguments.
267 -- We try to avoid this situation by generating code to test whether
268 -- we are calling a function with the correct number of arguments
269 -- first, i.e.:
270 --
271 -- if (TAG(f) != 0} { // f is not a thunk
272 -- if (f->info.arity == n) {
273 -- ... make a fast call to f ...
274 -- }
275 -- }
276 -- ... otherwise make the slow call ...
277 --
278 -- We *only* do this when the call requires multiple generic apply
279 -- functions, which requires pushing extra stack frames and probably
280 -- results in intermediate PAPs. (I say probably, because it might be
281 -- that we're over-applying a function, but that seems even less
282 -- likely).
283 --
284 -- This very rarely applies, but if it does happen in an inner loop it
285 -- can have a severe impact on performance (#6084).
286
287
288 --------------
289 direct_call :: String
290 -> Convention -- e.g. NativeNodeCall or NativeDirectCall
291 -> CLabel -> RepArity
292 -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
293 direct_call caller call_conv lbl arity args
294 | debugIsOn && args `lengthLessThan` real_arity -- Too few args
295 = do -- Caller should ensure that there enough args!
296 platform <- getPlatform
297 pprPanic "direct_call" $
298 text caller <+> ppr arity <+>
299 pdoc platform lbl <+> ppr (length args) <+>
300 pdoc platform (map snd args) <+> ppr (map fst args)
301
302 | null rest_args -- Precisely the right number of arguments
303 = emitCall (call_conv, NativeReturn) target (nonVArgs args)
304
305 | otherwise -- Note [over-saturated calls]
306 = do dflags <- getDynFlags
307 emitCallWithExtraStack (call_conv, NativeReturn)
308 target
309 (nonVArgs fast_args)
310 (nonVArgs (stack_args dflags))
311 where
312 target = CmmLit (CmmLabel lbl)
313 (fast_args, rest_args) = splitAt real_arity args
314 stack_args dflags = slowArgs dflags rest_args
315 real_arity = case call_conv of
316 NativeNodeCall -> arity+1
317 _ -> arity
318
319
320 -- When constructing calls, it is easier to keep the ArgReps and the
321 -- CmmExprs zipped together. However, a void argument has no
322 -- representation, so we need to use Maybe CmmExpr (the alternative of
323 -- using zeroCLit or even undefined would work, but would be ugly).
324 --
325 getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
326 getArgRepsAmodes args = do
327 platform <- profilePlatform <$> getProfile
328 mapM (getArgRepAmode platform) args
329 where getArgRepAmode platform arg
330 | V <- rep = return (V, Nothing)
331 | otherwise = do expr <- getArgAmode (NonVoid arg)
332 return (rep, Just expr)
333 where rep = toArgRep platform (argPrimRep arg)
334
335 nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
336 nonVArgs [] = []
337 nonVArgs ((_,Nothing) : args) = nonVArgs args
338 nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
339
340 {-
341 Note [over-saturated calls]
342
343 The natural thing to do for an over-saturated call would be to call
344 the function with the correct number of arguments, and then apply the
345 remaining arguments to the value returned, e.g.
346
347 f a b c d (where f has arity 2)
348 -->
349 r = call f(a,b)
350 call r(c,d)
351
352 but this entails
353 - saving c and d on the stack
354 - making a continuation info table
355 - at the continuation, loading c and d off the stack into regs
356 - finally, call r
357
358 Note that since there are a fixed number of different r's
359 (e.g. stg_ap_pp_fast), we can also pre-compile continuations
360 that correspond to each of them, rather than generating a fresh
361 one for each over-saturated call.
362
363 Not only does this generate much less code, it is faster too. We will
364 generate something like:
365
366 Sp[old+16] = c
367 Sp[old+24] = d
368 Sp[old+32] = stg_ap_pp_info
369 call f(a,b) -- usual calling convention
370
371 For the purposes of the CmmCall node, we count this extra stack as
372 just more arguments that we are passing on the stack (cml_args).
373 -}
374
375 -- | 'slowArgs' takes a list of function arguments and prepares them for
376 -- pushing on the stack for "extra" arguments to a function which requires
377 -- fewer arguments than we currently have.
378 slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
379 slowArgs _ [] = []
380 slowArgs dflags args -- careful: reps contains voids (V), but args does not
381 | sccProfilingEnabled dflags
382 = save_cccs ++ this_pat ++ slowArgs dflags rest_args
383 | otherwise = this_pat ++ slowArgs dflags rest_args
384 where
385 (arg_pat, n) = slowCallPattern (map fst args)
386 (call_args, rest_args) = splitAt n args
387
388 stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
389 this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args
390 save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
391 save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
392
393 -------------------------------------------------------------------------
394 ---- Laying out objects on the heap and stack
395 -------------------------------------------------------------------------
396
397 -- The heap always grows upwards, so hpRel is easy to compute
398 hpRel :: VirtualHpOffset -- virtual offset of Hp
399 -> VirtualHpOffset -- virtual offset of The Thing
400 -> WordOff -- integer word offset
401 hpRel hp off = off - hp
402
403 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
404 -- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad
405 getHpRelOffset virtual_offset
406 = do platform <- getPlatform
407 hp_usg <- getHpUsage
408 return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset))
409
410 data FieldOffOrPadding a
411 = FieldOff (NonVoid a) -- Something that needs an offset.
412 ByteOff -- Offset in bytes.
413 | Padding ByteOff -- Length of padding in bytes.
414 ByteOff -- Offset in bytes.
415
416 -- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
417 -- of header the object has. This will be accounted for in the
418 -- offsets of the fields returned.
419 data ClosureHeader
420 = NoHeader
421 | StdHeader
422 | ThunkHeader
423
424 mkVirtHeapOffsetsWithPadding
425 :: Profile
426 -> ClosureHeader -- What kind of header to account for
427 -> [NonVoid (PrimRep, a)] -- Things to make offsets for
428 -> ( WordOff -- Total number of words allocated
429 , WordOff -- Number of words allocated for *pointers*
430 , [FieldOffOrPadding a] -- Either an offset or padding.
431 )
432
433 -- Things with their offsets from start of object in order of
434 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
435 -- First in list gets lowest offset, which is initial offset + 1.
436 --
437 -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
438 -- than the unboxed things
439
440 mkVirtHeapOffsetsWithPadding profile header things =
441 assert (not (any (isVoidRep . fst . fromNonVoid) things))
442 ( tot_wds
443 , bytesToWordsRoundUp platform bytes_of_ptrs
444 , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
445 )
446 where
447 platform = profilePlatform profile
448 hdr_words = case header of
449 NoHeader -> 0
450 StdHeader -> fixedHdrSizeW profile
451 ThunkHeader -> thunkHdrSize profile
452 hdr_bytes = wordsToBytes platform hdr_words
453
454 (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
455
456 (bytes_of_ptrs, ptrs_w_offsets) =
457 mapAccumL computeOffset 0 ptrs
458 (tot_bytes, non_ptrs_w_offsets) =
459 mapAccumL computeOffset bytes_of_ptrs non_ptrs
460
461 tot_wds = bytesToWordsRoundUp platform tot_bytes
462
463 final_pad_size = tot_wds * word_size - tot_bytes
464 final_pad
465 | final_pad_size > 0 = [(Padding final_pad_size
466 (hdr_bytes + tot_bytes))]
467 | otherwise = []
468
469 word_size = platformWordSizeInBytes platform
470
471 computeOffset bytes_so_far nv_thing =
472 (new_bytes_so_far, with_padding field_off)
473 where
474 (rep, thing) = fromNonVoid nv_thing
475
476 -- Size of the field in bytes.
477 !sizeB = primRepSizeB platform rep
478
479 -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
480 -- But not more than to a word.
481 !align = min word_size sizeB
482 !start = roundUpTo bytes_so_far align
483 !padding = start - bytes_so_far
484
485 -- Final offset is:
486 -- size of header + bytes_so_far + padding
487 !final_offset = hdr_bytes + bytes_so_far + padding
488 !new_bytes_so_far = start + sizeB
489 field_off = FieldOff (NonVoid thing) final_offset
490
491 with_padding field_off
492 | padding == 0 = [field_off]
493 | otherwise = [ Padding padding (hdr_bytes + bytes_so_far)
494 , field_off
495 ]
496
497
498 mkVirtHeapOffsets
499 :: Profile
500 -> ClosureHeader -- What kind of header to account for
501 -> [NonVoid (PrimRep,a)] -- Things to make offsets for
502 -> (WordOff, -- _Total_ number of words allocated
503 WordOff, -- Number of words allocated for *pointers*
504 [(NonVoid a, ByteOff)])
505 mkVirtHeapOffsets profile header things =
506 ( tot_wds
507 , ptr_wds
508 , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
509 )
510 where
511 (tot_wds, ptr_wds, things_offsets) =
512 mkVirtHeapOffsetsWithPadding profile header things
513
514 -- | Just like mkVirtHeapOffsets, but for constructors
515 mkVirtConstrOffsets
516 :: Profile -> [NonVoid (PrimRep, a)]
517 -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
518 mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader
519
520 -- | Just like mkVirtConstrOffsets, but used when we don't have the actual
521 -- arguments. Useful when e.g. generating info tables; we just need to know
522 -- sizes of pointer and non-pointer fields.
523 mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
524 mkVirtConstrSizes profile field_reps
525 = (tot_wds, ptr_wds)
526 where
527 (tot_wds, ptr_wds, _) =
528 mkVirtConstrOffsets profile
529 (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)
530
531 -------------------------------------------------------------------------
532 --
533 -- Making argument descriptors
534 --
535 -- An argument descriptor describes the layout of args on the stack,
536 -- both for * GC (stack-layout) purposes, and
537 -- * saving/restoring registers when a heap-check fails
538 --
539 -- Void arguments aren't important, therefore (contrast constructSlowCall)
540 --
541 -------------------------------------------------------------------------
542
543 -- bring in ARG_P, ARG_N, etc.
544 #include "FunTypes.h"
545
546 mkArgDescr :: Platform -> [Id] -> ArgDescr
547 mkArgDescr platform args
548 = let arg_bits = argBits platform arg_reps
549 arg_reps = filter isNonV (map (idArgRep platform) args)
550 -- Getting rid of voids eases matching of standard patterns
551 in case stdPattern arg_reps of
552 Just spec_id -> ArgSpec spec_id
553 Nothing -> ArgGen arg_bits
554
555 argBits :: Platform -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr
556 argBits _ [] = []
557 argBits platform (P : args) = False : argBits platform args
558 argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True)
559 ++ argBits platform args
560
561 ----------------------
562 stdPattern :: [ArgRep] -> Maybe Int
563 stdPattern reps
564 = case reps of
565 [] -> Just ARG_NONE -- just void args, probably
566 [N] -> Just ARG_N
567 [P] -> Just ARG_P
568 [F] -> Just ARG_F
569 [D] -> Just ARG_D
570 [L] -> Just ARG_L
571 [V16] -> Just ARG_V16
572 [V32] -> Just ARG_V32
573 [V64] -> Just ARG_V64
574
575 [N,N] -> Just ARG_NN
576 [N,P] -> Just ARG_NP
577 [P,N] -> Just ARG_PN
578 [P,P] -> Just ARG_PP
579
580 [N,N,N] -> Just ARG_NNN
581 [N,N,P] -> Just ARG_NNP
582 [N,P,N] -> Just ARG_NPN
583 [N,P,P] -> Just ARG_NPP
584 [P,N,N] -> Just ARG_PNN
585 [P,N,P] -> Just ARG_PNP
586 [P,P,N] -> Just ARG_PPN
587 [P,P,P] -> Just ARG_PPP
588
589 [P,P,P,P] -> Just ARG_PPPP
590 [P,P,P,P,P] -> Just ARG_PPPPP
591 [P,P,P,P,P,P] -> Just ARG_PPPPPP
592
593 _ -> Nothing
594
595 -------------------------------------------------------------------------
596 -- Amodes for arguments
597 -------------------------------------------------------------------------
598
599 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
600 getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
601 getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
602
603 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
604 -- NB: Filters out void args,
605 -- so the result list may be shorter than the argument list
606 getNonVoidArgAmodes [] = return []
607 getNonVoidArgAmodes (arg:args)
608 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
609 | otherwise = do { amode <- getArgAmode (NonVoid arg)
610 ; amodes <- getNonVoidArgAmodes args
611 ; return ( amode : amodes ) }
612
613 -------------------------------------------------------------------------
614 --
615 -- Generating the info table and code for a closure
616 --
617 -------------------------------------------------------------------------
618
619 -- Here we make an info table of type 'CmmInfo'. The concrete
620 -- representation as a list of 'CmmAddr' is handled later
621 -- in the pipeline by 'cmmToRawCmm'.
622 -- When loading the free variables, a function closure pointer may be tagged,
623 -- so we must take it into account.
624
625 emitClosureProcAndInfoTable :: Bool -- top-level?
626 -> Id -- name of the closure
627 -> LambdaFormInfo
628 -> CmmInfoTable
629 -> [NonVoid Id] -- incoming arguments
630 -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
631 -> FCode ()
632 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
633 = do { profile <- getProfile
634 ; platform <- getPlatform
635 -- Bind the binder itself, but only if it's not a top-level
636 -- binding. We need non-top let-bindings to refer to the
637 -- top-level binding, which this binding would incorrectly shadow.
638 ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)
639 else bindToReg (NonVoid bndr) lf_info
640 ; let node_points = nodeMustPointToIt profile lf_info
641 ; arg_regs <- bindArgsToRegs args
642 ; let args' = if node_points then (node : arg_regs) else arg_regs
643 conv = if nodeMustPointToIt profile lf_info then NativeNodeCall
644 else NativeDirectCall
645 (offset, _, _) = mkCallEntry profile conv args' []
646 ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs)
647 }
648
649 -- Data constructors need closures, but not with all the argument handling
650 -- needed for functions. The shared part goes here.
651 emitClosureAndInfoTable
652 :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
653 emitClosureAndInfoTable platform info_tbl conv args body
654 = do { (_, blks) <- getCodeScoped body
655 ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)
656 ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
657 }