genapply: update source file in autogenerated text
[ghc.git] / utils / genapply / Main.hs
1 {-# LANGUAGE CPP #-}
2 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
3 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
4 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
5 {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
6 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
7 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
8 -- The above warning suppression flags are a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 -- for details
13 module Main(main) where
14
15 #include "../../includes/ghcconfig.h"
16 #include "../../includes/stg/HaskellMachRegs.h"
17 #include "../../includes/rts/Constants.h"
18
19 -- Needed for TAG_BITS
20 #include "../../includes/MachDeps.h"
21
22 import Text.PrettyPrint
23 import Data.Word
24 import Data.Bits
25 import Data.List ( intersperse, nub, sort )
26 import System.Exit
27 import System.Environment
28 import System.IO
29 import Control.Arrow ((***))
30
31 -- -----------------------------------------------------------------------------
32 -- Argument kinds (rougly equivalent to PrimRep)
33
34 data ArgRep
35 = N -- non-ptr
36 | P -- ptr
37 | V -- void
38 | F -- float
39 | D -- double
40 | L -- long (64-bit)
41 | V16 -- 16-byte (128-bit) vectors
42 | V32 -- 32-byte (256-bit) vectors
43 | V64 -- 64-byte (512-bit) vectors
44
45 -- size of a value in *words*
46 argSize :: ArgRep -> Int
47 argSize N = 1
48 argSize P = 1
49 argSize V = 0
50 argSize F = 1
51 argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
52 argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
53 argSize V16 = (16 `quot` SIZEOF_VOID_P :: Int)
54 argSize V32 = (32 `quot` SIZEOF_VOID_P :: Int)
55 argSize V64 = (64 `quot` SIZEOF_VOID_P :: Int)
56
57 showArg :: ArgRep -> String
58 showArg N = "n"
59 showArg P = "p"
60 showArg V = "v"
61 showArg F = "f"
62 showArg D = "d"
63 showArg L = "l"
64 showArg V16 = "v16"
65 showArg V32 = "v32"
66 showArg V64 = "v64"
67
68 -- is a value a pointer?
69 isPtr :: ArgRep -> Bool
70 isPtr P = True
71 isPtr _ = False
72
73 -- -----------------------------------------------------------------------------
74 -- Registers
75
76 data RegStatus = Registerised | Unregisterised
77
78 type Reg = String
79
80 availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
81 availableRegs Unregisterised = ([],[],[],[])
82 availableRegs Registerised =
83 ( vanillaRegs MAX_REAL_VANILLA_REG,
84 floatRegs MAX_REAL_FLOAT_REG,
85 doubleRegs MAX_REAL_DOUBLE_REG,
86 longRegs MAX_REAL_LONG_REG
87 )
88
89 vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
90 vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
91 floatRegs n = [ "F" ++ show m | m <- [1..n] ]
92 doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
93 longRegs n = [ "L" ++ show m | m <- [1..n] ]
94
95 -- -----------------------------------------------------------------------------
96 -- Loading/saving register arguments to the stack
97
98 loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
99 loadRegArgs regstatus sp args
100 = (loadRegOffs reg_locs, sp')
101 where (reg_locs, _, sp') = assignRegs regstatus sp args
102
103 loadRegOffs :: [(Reg,Int)] -> Doc
104 loadRegOffs = vcat . map (uncurry assign_stk_to_reg)
105
106 saveRegOffs :: [(Reg,Int)] -> Doc
107 saveRegOffs = vcat . map (uncurry assign_reg_to_stk)
108
109 -- a bit like assignRegs in CgRetConv.lhs
110 assignRegs
111 :: RegStatus -- are we registerised?
112 -> Int -- Sp of first arg
113 -> [ArgRep] -- args
114 -> ([(Reg,Int)], -- regs and offsets to load
115 [ArgRep], -- left-over args
116 Int) -- Sp of left-over args
117 assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
118
119 assign sp [] regs doc = (doc, [], sp)
120 assign sp (V : args) regs doc = assign sp args regs doc
121 assign sp (arg : args) regs doc
122 = case findAvailableReg arg regs of
123 Just (reg, regs') -> assign (sp + argSize arg) args regs'
124 ((reg, sp) : doc)
125 Nothing -> (doc, (arg:args), sp)
126
127 findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
128 Just (vreg, (vregs,fregs,dregs,lregs))
129 findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
130 Just (vreg, (vregs,fregs,dregs,lregs))
131 findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
132 Just (freg, (vregs,fregs,dregs,lregs))
133 findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
134 Just (dreg, (vregs,fregs,dregs,lregs))
135 findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
136 Just (lreg, (vregs,fregs,dregs,lregs))
137 findAvailableReg _ _ = Nothing
138
139 assign_reg_to_stk reg sp
140 = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
141
142 assign_stk_to_reg reg sp
143 = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
144
145 regRep ('F':_) = "F_"
146 regRep ('D':_) = "D_"
147 regRep ('L':_) = "L_"
148 regRep _ = "W_"
149
150 loadSpWordOff :: String -> Int -> Doc
151 loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
152
153 -- Make a jump
154 mkJump :: RegStatus -- Registerised status
155 -> Doc -- Jump target
156 -> [Reg] -- Registers that are definitely live
157 -> [ArgRep] -- Jump arguments
158 -> Doc
159 mkJump regstatus jump live args =
160 text "jump" <+> jump <+> brackets (hcat (punctuate comma liveRegs))
161 where
162 liveRegs = mkJumpLiveRegs regstatus live args
163
164 -- Make a jump, saving CCCS and restoring it on return
165 mkJumpSaveCCCS :: RegStatus -- Registerised status
166 -> Doc -- Jump target
167 -> [Reg] -- Registers that are definitely live
168 -> [ArgRep] -- Jump arguments
169 -> Doc
170 mkJumpSaveCCCS regstatus jump live args =
171 text "jump_SAVE_CCCS" <> parens (hcat (punctuate comma (jump : liveRegs)))
172 where
173 liveRegs = mkJumpLiveRegs regstatus live args
174
175 -- Calculate live registers for a jump
176 mkJumpLiveRegs :: RegStatus -- Registerised status
177 -> [Reg] -- Registers that are definitely live
178 -> [ArgRep] -- Jump arguments
179 -> [Doc]
180 mkJumpLiveRegs regstatus live args =
181 map text regs
182 where
183 (reg_locs, _, _) = assignRegs regstatus 0 args
184 regs = (nub . sort) (live ++ map fst reg_locs)
185
186 -- make a ptr/non-ptr bitmap from a list of argument types
187 mkBitmap :: [ArgRep] -> Word32
188 mkBitmap args = foldr f 0 args
189 where f arg bm | isPtr arg = bm `shiftL` 1
190 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
191 where size = argSize arg
192
193 -- -----------------------------------------------------------------------------
194 -- Generating the application functions
195
196 -- A SUBTLE POINT about stg_ap functions (can't think of a better
197 -- place to put this comment --SDM):
198 --
199 -- The entry convention to an stg_ap_ function is as follows: all the
200 -- arguments are on the stack (we might revisit this at some point,
201 -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
202 -- EMPTY STACK SLOT at the top of the stack.
203 --
204 -- Why? Because in several cases, stg_ap_* will need an extra stack
205 -- slot, eg. to push a return address in the THUNK case, and this is a
206 -- way of pushing the stack check up into the caller which is probably
207 -- doing one anyway. Allocating the extra stack slot in the caller is
208 -- also probably free, because it will be adjusting Sp after pushing
209 -- the args anyway (this might not be true of register-rich machines
210 -- when we start passing args to stg_ap_* in regs).
211
212 mkApplyName args
213 = text "stg_ap_" <> text (concatMap showArg args)
214
215 mkApplyRetName args
216 = mkApplyName args <> text "_ret"
217
218 mkApplyFastName args
219 = mkApplyName args <> text "_fast"
220
221 mkApplyInfoName args
222 = mkApplyName args <> text "_info"
223
224 mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
225 | otherwise = empty
226
227 mkTagStmt tag = text ("R1 = R1 + "++ show tag)
228
229 type StackUsage = (Int, Int) -- PROFILING, normal
230
231 maxStack :: [StackUsage] -> StackUsage
232 maxStack = (maximum *** maximum) . unzip
233
234 stackCheck
235 :: RegStatus -- Registerised status
236 -> [ArgRep]
237 -> Bool -- args in regs?
238 -> Doc -- fun_info_label
239 -> StackUsage
240 -> Doc
241 stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
242 let
243 (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
244
245 cmp_sp n
246 | n > 0 =
247 text "if (Sp - WDS(" <> int n <> text ") < SpLim) {" $$
248 nest 4 (vcat [
249 if args_in_regs
250 then
251 text "Sp_adj" <> parens (int (-sp_offset)) <> semi $$
252 saveRegOffs reg_locs
253 else
254 empty,
255 text "Sp(0) = " <> fun_info_label <> char ';',
256 mkJump regstatus (text "__stg_gc_enter_1") ["R1"] [] <> semi
257 ]) $$
258 char '}'
259 | otherwise = empty
260 in
261 vcat [ text "#ifdef PROFILING",
262 cmp_sp prof_sp,
263 text "#else",
264 cmp_sp norm_sp,
265 text "#endif"
266 ]
267
268 genMkPAP :: RegStatus -- Register status
269 -> String -- Macro
270 -> String -- Jump target
271 -> [Reg] -- Registers that are definitely live
272 -> String -- Ticker
273 -> String -- Disamb
274 -> Bool -- Don't load argument registers before jump if True
275 -> Bool -- Arguments already in registers if True
276 -> Bool -- Is a PAP if True
277 -> [ArgRep] -- Arguments
278 -> Int -- Size of all arguments
279 -> Doc -- info label
280 -> Bool -- Is a function
281 -> (Doc, StackUsage)
282 genMkPAP regstatus macro jump live ticker disamb
283 no_load_regs -- don't load argument regs before jumping
284 args_in_regs -- arguments are already in regs
285 is_pap args all_args_size fun_info_label
286 is_fun_case
287 = (doc, stack_usage)
288
289 where
290 doc = vcat smaller_arity_doc $$ exact_arity_case $$ larger_arity_doc
291
292 stack_usage = maxStack (larger_arity_stack : smaller_arity_stack)
293
294 n_args = length args
295
296 -- offset of arguments on the stack at slow apply calls.
297 stk_args_slow_offset = 1
298
299 stk_args_offset
300 | args_in_regs = 0
301 | otherwise = stk_args_slow_offset
302
303 -- The SMALLER ARITY cases:
304 -- if (arity == 1) {
305 -- Sp[0] = Sp[1];
306 -- Sp[1] = (W_)&stg_ap_1_info;
307 -- JMP_(GET_ENTRY(R1.cl));
308 (smaller_arity_doc, smaller_arity_stack)
309 = unzip [ smaller_arity i | i <- [1..n_args-1] ]
310
311 smaller_arity arity = (doc, stack_usage)
312 where
313 (save_regs, stack_usage)
314 | overflow_regs = save_extra_regs
315 | otherwise = shuffle_extra_args
316
317 doc =
318 text "if (arity == " <> int arity <> text ") {" $$
319 nest 4 (vcat [
320 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
321
322 -- load up regs for the call, if necessary
323 load_regs,
324
325 -- If we have more args in registers than are required
326 -- for the call, then we must save some on the stack,
327 -- and set up the stack for the follow-up call.
328 -- If the extra arguments are on the stack, then we must
329 -- instead shuffle them down to make room for the info
330 -- table for the follow-on call.
331 save_regs,
332
333 -- for a PAP, we have to arrange that the stack contains a
334 -- return address in the event that stg_PAP_entry fails its
335 -- heap check. See stg_PAP_entry in Apply.hc for details.
336 if is_pap
337 then text "R2 = " <> mkApplyInfoName this_call_args <> semi
338
339 else empty,
340 if is_fun_case then mb_tag_node arity else empty,
341 if overflow_regs
342 then mkJumpSaveCCCS
343 regstatus (text jump) live (take arity args) <> semi
344 else mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
345 ]) $$
346 text "}"
347
348 -- offsets in case we need to save regs:
349 (reg_locs, _, _)
350 = assignRegs regstatus stk_args_offset args
351
352 -- register assignment for *this function call*
353 (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
354 = assignRegs regstatus stk_args_offset (take arity args)
355
356 load_regs
357 | no_load_regs || args_in_regs = empty
358 | otherwise = loadRegOffs reg_locs'
359
360 (this_call_args, rest_args) = splitAt arity args
361
362 -- the offset of the stack args from initial Sp
363 sp_stk_args
364 | args_in_regs = stk_args_offset
365 | no_load_regs = stk_args_offset
366 | otherwise = reg_call_sp_stk_args
367
368 -- the stack args themselves
369 this_call_stack_args
370 | args_in_regs = reg_call_leftovers -- sp offsets are wrong
371 | no_load_regs = this_call_args
372 | otherwise = reg_call_leftovers
373
374 stack_args_size = sum (map argSize this_call_stack_args)
375
376 overflow_regs = args_in_regs && length reg_locs > length reg_locs'
377
378 save_extra_regs = (doc, (size,size))
379 where
380 -- we have extra arguments in registers to save
381 extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
382 adj_reg_locs = [ (reg, off - adj + 1) |
383 (reg,off) <- extra_reg_locs ]
384 adj = case extra_reg_locs of
385 (reg, fst_off):_ -> fst_off
386 size = snd (last adj_reg_locs) + 1
387
388 doc =
389 text "Sp_adj(" <> int (-size) <> text ");" $$
390 saveRegOffs adj_reg_locs $$
391 loadSpWordOff "W_" 0 <> text " = " <>
392 mkApplyInfoName rest_args <> semi
393
394 shuffle_extra_args = (doc, (shuffle_prof_stack, shuffle_norm_stack))
395 where
396 doc = vcat [ text "#ifdef PROFILING",
397 shuffle_prof_doc,
398 text "#else",
399 shuffle_norm_doc,
400 text "#endif"]
401
402 (shuffle_prof_doc, shuffle_prof_stack) = shuffle True
403 (shuffle_norm_doc, shuffle_norm_stack) = shuffle False
404
405 -- Sadly here we have to insert an stg_restore_cccs frame
406 -- just underneath the stg_ap_*_info frame if we're
407 -- profiling; see Note [jump_SAVE_CCCS]
408 shuffle prof = (doc, -sp_adj)
409 where
410 sp_adj = sp_stk_args - 1 - offset
411 offset = if prof then 2 else 0
412 doc =
413 vcat (map (shuffle_down (offset+1))
414 [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
415 (if prof
416 then
417 loadSpWordOff "W_" (sp_stk_args+stack_args_size-3)
418 <> text " = stg_restore_cccs_info;" $$
419 loadSpWordOff "W_" (sp_stk_args+stack_args_size-2)
420 <> text " = CCCS;"
421 else empty) $$
422 loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
423 <> text " = "
424 <> mkApplyInfoName rest_args <> semi $$
425 text "Sp_adj(" <> int sp_adj <> text ");"
426
427 shuffle_down j i =
428 loadSpWordOff "W_" (i-j) <> text " = " <>
429 loadSpWordOff "W_" i <> semi
430
431
432 -- The EXACT ARITY case
433 --
434 -- if (arity == 1) {
435 -- Sp++;
436 -- JMP_(GET_ENTRY(R1.cl));
437
438 exact_arity_case
439 = text "if (arity == " <> int n_args <> text ") {" $$
440 let
441 (reg_doc, sp')
442 | no_load_regs || args_in_regs = (empty, stk_args_offset)
443 | otherwise = loadRegArgs regstatus stk_args_offset args
444 in
445 nest 4 (vcat [
446 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
447 reg_doc,
448 text "Sp_adj(" <> int sp' <> text ");",
449 if is_pap
450 then text "R2 = " <> fun_info_label <> semi
451 else empty,
452 if is_fun_case then mb_tag_node n_args else empty,
453 mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
454 ])
455
456 -- The LARGER ARITY cases:
457 --
458 -- } else /* arity > 1 */ {
459 -- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
460 -- }
461
462 (larger_arity_doc, larger_arity_stack) = (doc, stack)
463 where
464 -- offsets in case we need to save regs:
465 (reg_locs, leftovers, sp_offset)
466 = assignRegs regstatus stk_args_slow_offset args
467 -- BUILD_PAP assumes args start at offset 1
468
469 stack | args_in_regs = (sp_offset, sp_offset)
470 | otherwise = (0,0)
471
472 doc =
473 text "} else {" $$
474 let
475 save_regs
476 | args_in_regs =
477 text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
478 saveRegOffs reg_locs
479 | otherwise =
480 empty
481 in
482 nest 4 (vcat [
483 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
484 save_regs,
485 -- Before building the PAP, tag the function closure pointer
486 if is_fun_case then
487 vcat [
488 text "if (arity < " <> int tAG_BITS_MAX <> text ") {",
489 text " R1 = R1 + arity" <> semi,
490 text "}"
491 ]
492 else empty
493 ,
494 text macro <> char '(' <> int n_args <> comma <>
495 int all_args_size <>
496 text "," <> fun_info_label <>
497 text "," <> text disamb <>
498 text ");"
499 ]) $$
500 char '}'
501
502
503 -- Note [jump_SAVE_CCCS]
504
505 -- when profiling, if we have some extra arguments to apply that we
506 -- save to the stack, we must also save the current cost centre stack
507 -- and restore it when applying the extra arguments. This is all
508 -- handled by the macro jump_SAVE_CCCS(target), defined in
509 -- rts/AutoApply.h.
510 --
511 -- At the jump, the stack will look like this:
512 --
513 -- ... extra args ...
514 -- stg_ap_pp_info
515 -- CCCS
516 -- stg_restore_cccs_info
517
518 -- --------------------------------------
519 -- Examine tag bits of function pointer and enter it
520 -- directly if needed.
521 -- TODO: remove the redundant case in the original code.
522 enterFastPath regstatus no_load_regs args_in_regs args
523 | Just tag <- tagForArity (length args)
524 = enterFastPathHelper tag regstatus no_load_regs args_in_regs args
525 enterFastPath _ _ _ _ = empty
526
527 -- Copied from Constants.lhs & CgUtils.hs, i'd rather have this imported:
528 -- (arity,tag)
529 tAG_BITS = (TAG_BITS :: Int)
530 tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int)
531
532 tagForArity :: Int -> Maybe Int
533 tagForArity i | i < tAG_BITS_MAX = Just i
534 | otherwise = Nothing
535
536 enterFastPathHelper :: Int
537 -> RegStatus
538 -> Bool
539 -> Bool
540 -> [ArgRep]
541 -> Doc
542 enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
543 text "if (GETTAG(R1)==" <> int tag <> text ") {" $$
544 nest 4 (vcat [
545 reg_doc,
546 text "Sp_adj(" <> int sp' <> text ");",
547 -- enter, but adjust offset with tag
548 mkJump regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi
549 ]) $$
550 text "}"
551 -- I don't totally understand this code, I copied it from
552 -- exact_arity_case
553 -- TODO: refactor
554 where
555 -- offset of arguments on the stack at slow apply calls.
556 stk_args_slow_offset = 1
557
558 stk_args_offset
559 | args_in_regs = 0
560 | otherwise = stk_args_slow_offset
561
562 (reg_doc, sp')
563 | no_load_regs || args_in_regs = (empty, stk_args_offset)
564 | otherwise = loadRegArgs regstatus stk_args_offset args
565
566 tickForArity arity
567 | True
568 = empty
569 | Just tag <- tagForArity arity
570 = vcat [
571 text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;",
572 text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;",
573 text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {",
574 text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;",
575 text " if (GETTAG(R1)==" <> int tag <> text ") {",
576 text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;",
577 text " } else {",
578 -- force a halt when not tagged!
579 -- text " W_[0]=0;",
580 text " }",
581 text "}"
582 ]
583 tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
584
585 -- -----------------------------------------------------------------------------
586 -- generate an apply function
587
588 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
589 formalParam :: ArgRep -> Int -> Doc
590 formalParam V _ = empty
591 formalParam arg n =
592 formalParamType arg <> space <>
593 text "arg" <> int n <> text ", "
594 formalParamType arg = argRep arg
595
596 argRep F = text "F_"
597 argRep D = text "D_"
598 argRep L = text "L_"
599 argRep P = text "gcptr"
600 argRep V16 = text "V16_"
601 argRep V32 = text "V32_"
602 argRep V64 = text "V64_"
603 argRep _ = text "W_"
604
605 genApply :: RegStatus -> [ArgRep] -> Doc
606 genApply regstatus args =
607 let
608 fun_ret_label = mkApplyRetName args
609 fun_info_label = mkApplyInfoName args
610 all_args_size = sum (map argSize args)
611
612 (bco_doc, bco_stack) =
613 genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
614 True{-stack apply-} False{-args on stack-} False{-not a PAP-}
615 args all_args_size fun_info_label {- tag stmt -}False
616
617 (fun_doc, fun_stack) =
618 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
619 False{-reg apply-} False{-args on stack-} False{-not a PAP-}
620 args all_args_size fun_info_label {- tag stmt -}True
621
622 (pap_doc, pap_stack) =
623 genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
624 True{-stack apply-} False{-args on stack-} True{-is a PAP-}
625 args all_args_size fun_info_label {- tag stmt -}False
626
627 stack_usage = maxStack [bco_stack, fun_stack, pap_stack]
628 in
629 vcat [
630 text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
631 text "RET_SMALL, W_ info_ptr, " <> (cat $ zipWith formalParam args [1..]) <>
632 text ")\n{",
633 nest 4 (vcat [
634 text "W_ info;",
635 text "W_ arity;",
636 text "unwind Sp = Sp + WDS(" <> int (1+all_args_size) <> text ");",
637
638 -- if fast == 1:
639 -- print "static void *lbls[] ="
640 -- print " { [FUN] &&fun_lbl,"
641 -- print " [FUN_1_0] &&fun_lbl,"
642 -- print " [FUN_0_1] &&fun_lbl,"
643 -- print " [FUN_2_0] &&fun_lbl,"
644 -- print " [FUN_1_1] &&fun_lbl,"
645 -- print " [FUN_0_2] &&fun_lbl,"
646 -- print " [FUN_STATIC] &&fun_lbl,"
647 -- print " [PAP] &&pap_lbl,"
648 -- print " [THUNK] &&thunk_lbl,"
649 -- print " [THUNK_1_0] &&thunk_lbl,"
650 -- print " [THUNK_0_1] &&thunk_lbl,"
651 -- print " [THUNK_2_0] &&thunk_lbl,"
652 -- print " [THUNK_1_1] &&thunk_lbl,"
653 -- print " [THUNK_0_2] &&thunk_lbl,"
654 -- print " [THUNK_STATIC] &&thunk_lbl,"
655 -- print " [THUNK_SELECTOR] &&thunk_lbl,"
656 -- print " [IND] &&ind_lbl,"
657 -- print " [IND_STATIC] &&ind_lbl,"
658 -- print " };"
659
660 tickForArity (length args),
661 text "",
662 text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
663 text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
664
665 text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
666 <> text ")\"ptr\"));",
667
668 -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
669 -- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
670
671 -- text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
672
673 let do_assert [] _ = []
674 do_assert (arg:args) offset
675 | isPtr arg = this : rest
676 | otherwise = rest
677 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
678 <> int offset <> text ")));"
679 rest = do_assert args (offset + argSize arg)
680 in
681 vcat (do_assert args 1),
682
683 text "again:",
684
685 -- if pointer is tagged enter it fast!
686 enterFastPath regstatus False False args,
687
688 stackCheck regstatus args False{-args on stack-}
689 fun_info_label stack_usage,
690
691 -- Functions can be tagged, so we untag them!
692 text "R1 = UNTAG(R1);",
693 text "info = %INFO_PTR(R1);",
694
695 -- if fast == 1:
696 -- print " goto *lbls[info->type];";
697 -- else:
698 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
699 nest 4 (vcat [
700
701 -- if fast == 1:
702 -- print " bco_lbl:"
703 -- else:
704 text "case BCO: {",
705 nest 4 (vcat [
706 text "arity = TO_W_(StgBCO_arity(R1));",
707 text "ASSERT(arity > 0);",
708 bco_doc
709 ]),
710 text "}",
711
712 -- if fast == 1:
713 -- print " fun_lbl:"
714 -- else:
715 text "case FUN,",
716 text " FUN_1_0,",
717 text " FUN_0_1,",
718 text " FUN_2_0,",
719 text " FUN_1_1,",
720 text " FUN_0_2,",
721 text " FUN_STATIC: {",
722 nest 4 (vcat [
723 text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
724 text "ASSERT(arity > 0);",
725 fun_doc
726 ]),
727 text "}",
728
729 -- if fast == 1:
730 -- print " pap_lbl:"
731 -- else:
732
733 text "case PAP: {",
734 nest 4 (vcat [
735 text "arity = TO_W_(StgPAP_arity(R1));",
736 text "ASSERT(arity > 0);",
737 pap_doc
738 ]),
739 text "}",
740
741 text "",
742
743 -- if fast == 1:
744 -- print " thunk_lbl:"
745 -- else:
746 text "case AP,",
747 text " AP_STACK,",
748 text " BLACKHOLE,",
749 text " WHITEHOLE,",
750 text " THUNK,",
751 text " THUNK_1_0,",
752 text " THUNK_0_1,",
753 text " THUNK_2_0,",
754 text " THUNK_1_1,",
755 text " THUNK_0_2,",
756 text " THUNK_STATIC,",
757 text " THUNK_SELECTOR: {",
758 nest 4 (vcat [
759 -- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
760 text "Sp(0) = " <> fun_info_label <> text ";",
761 -- CAREFUL! in SMP mode, the info table may already have been
762 -- overwritten by an indirection, so we must enter the original
763 -- info pointer we read, don't read it again, because it might
764 -- not be enterable any more.
765 mkJumpSaveCCCS
766 regstatus (text "%ENTRY_CODE(info)") ["R1"] args <> semi,
767 -- see Note [jump_SAVE_CCCS]
768 text ""
769 ]),
770 text "}",
771
772 -- if fast == 1:
773 -- print " ind_lbl:"
774 -- else:
775 text "case IND,",
776 text " IND_STATIC: {",
777 nest 4 (vcat [
778 text "R1 = StgInd_indirectee(R1);",
779 -- An indirection node might contain a tagged pointer
780 text "goto again;"
781 ]),
782 text "}",
783 text "",
784
785 -- if fast == 0:
786
787 text "default: {",
788 nest 4 (
789 text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;"
790 ),
791 text "}"
792
793 ]),
794 text "}"
795 ]),
796
797 text "}"
798 ]
799
800 -- -----------------------------------------------------------------------------
801 -- Making a fast unknown application, args are in regs
802
803 genApplyFast :: RegStatus -> [ArgRep] -> Doc
804 genApplyFast regstatus args =
805 let
806 fun_fast_label = mkApplyFastName args
807 fun_ret_label = text "RET_LBL" <> parens (mkApplyName args)
808 fun_info_label = mkApplyInfoName args
809 all_args_size = sum (map argSize args)
810
811 (fun_doc, fun_stack) =
812 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
813 False{-reg apply-} True{-args in regs-} False{-not a PAP-}
814 args all_args_size fun_info_label {- tag stmt -}True
815
816 (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
817
818 stack_usage = maxStack [fun_stack, (sp_offset,sp_offset)]
819 in
820 vcat [
821 fun_fast_label,
822 char '{',
823 nest 4 (vcat [
824 text "W_ info;",
825 text "W_ arity;",
826
827 tickForArity (length args),
828
829 -- if pointer is tagged enter it fast!
830 enterFastPath regstatus False True args,
831
832 stackCheck regstatus args True{-args in regs-}
833 fun_info_label stack_usage,
834
835 -- Functions can be tagged, so we untag them!
836 text "R1 = UNTAG(R1);",
837 text "info = %GET_STD_INFO(R1);",
838 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
839 nest 4 (vcat [
840 text "case FUN,",
841 text " FUN_1_0,",
842 text " FUN_0_1,",
843 text " FUN_2_0,",
844 text " FUN_1_1,",
845 text " FUN_0_2,",
846 text " FUN_STATIC: {",
847 nest 4 (vcat [
848 text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
849 text "ASSERT(arity > 0);",
850 fun_doc
851 ]),
852 char '}',
853
854 text "default: {",
855 nest 4 (vcat [
856 text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
857 saveRegOffs reg_locs,
858 mkJump regstatus fun_ret_label [] [] <> semi
859 ]),
860 char '}'
861 ]),
862
863 char '}'
864 ]),
865 char '}'
866 ]
867
868 -- -----------------------------------------------------------------------------
869 -- Making a stack apply
870
871 -- These little functions are like slow entry points. They provide
872 -- the layer between the PAP entry code and the function's fast entry
873 -- point: namely they load arguments off the stack into registers (if
874 -- available) and jump to the function's entry code.
875 --
876 -- On entry: R1 points to the function closure
877 -- arguments are on the stack starting at Sp
878 --
879 -- Invariant: the list of arguments never contains void. Since we're only
880 -- interested in loading arguments off the stack here, we can ignore
881 -- void arguments.
882
883 mkStackApplyEntryLabel:: [ArgRep] -> Doc
884 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (concatMap showArg args)
885
886 genStackApply :: RegStatus -> [ArgRep] -> Doc
887 genStackApply regstatus args =
888 let fn_entry_label = mkStackApplyEntryLabel args in
889 vcat [
890 fn_entry_label,
891 text "{", nest 4 body, text "}"
892 ]
893 where
894 (assign_regs, sp') = loadRegArgs regstatus 0 args
895 body = vcat [assign_regs,
896 text "Sp_adj" <> parens (int sp') <> semi,
897 mkJump regstatus (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args <> semi
898 ]
899
900 -- -----------------------------------------------------------------------------
901 -- Stack save entry points.
902 --
903 -- These code fragments are used to save registers on the stack at a heap
904 -- check failure in the entry code for a function. We also have to save R1
905 -- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
906 -- in HeapStackCheck.hc for more details.
907
908 mkStackSaveEntryLabel :: [ArgRep] -> Doc
909 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (concatMap showArg args)
910
911 genStackSave :: RegStatus -> [ArgRep] -> Doc
912 genStackSave regstatus args =
913 let fn_entry_label= mkStackSaveEntryLabel args in
914 vcat [
915 fn_entry_label,
916 text "{", nest 4 body, text "}"
917 ]
918 where
919 body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
920 saveRegOffs reg_locs,
921 text "Sp(2) = R1;",
922 text "Sp(1) =" <+> int stk_args <> semi,
923 text "Sp(0) = stg_gc_fun_info;",
924 text "jump stg_gc_noregs [];"
925 ]
926
927 std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
928 -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
929 (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
930
931 -- number of words of arguments on the stack.
932 stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
933
934 -- -----------------------------------------------------------------------------
935 -- The prologue...
936
937 main = do
938 args <- getArgs
939 regstatus <- case args of
940 [] -> return Registerised
941 ["-u"] -> return Unregisterised
942 _other -> do hPutStrLn stderr "syntax: genapply [-u]"
943 exitWith (ExitFailure 1)
944 let the_code = vcat [
945 text "// DO NOT EDIT!",
946 text "// Automatically generated by utils/genapply/Main.hs",
947 text "",
948 text "#include \"Cmm.h\"",
949 text "#include \"AutoApply.h\"",
950 text "",
951
952 vcat (intersperse (text "") $
953 map (genApply regstatus) applyTypes),
954 vcat (intersperse (text "") $
955 map (genStackFns regstatus) stackApplyTypes),
956
957 vcat (intersperse (text "") $
958 map (genApplyFast regstatus) applyTypes),
959
960 genStackApplyArray stackApplyTypes,
961 genStackSaveArray stackApplyTypes,
962 genBitmapArray stackApplyTypes,
963
964 text "" -- add a newline at the end of the file
965 ]
966 -- in
967 putStr (render the_code)
968
969 -- These have been shown to cover about 99% of cases in practice...
970 applyTypes = [
971 [V],
972 [F],
973 [D],
974 [L],
975 [V16],
976 [V32],
977 [V64],
978 [N],
979 [P],
980 [P,V],
981 [P,P],
982 [P,P,V],
983 [P,P,P],
984 [P,P,P,V],
985 [P,P,P,P],
986 [P,P,P,P,P],
987 [P,P,P,P,P,P]
988 ]
989
990 -- No need for V args in the stack apply cases.
991 -- ToDo: the stack apply and stack save code doesn't make a distinction
992 -- between N and P (they both live in the same register), only the bitmap
993 -- changes, so we could share the apply/save code between lots of cases.
994 --
995 -- NOTE: other places to change if you change stackApplyTypes:
996 -- - includes/rts/storage/FunTypes.h
997 -- - compiler/codeGen/CgCallConv.lhs: stdPattern
998 stackApplyTypes = [
999 [],
1000 [N],
1001 [P],
1002 [F],
1003 [D],
1004 [L],
1005 [V16],
1006 [V32],
1007 [V64],
1008 [N,N],
1009 [N,P],
1010 [P,N],
1011 [P,P],
1012 [N,N,N],
1013 [N,N,P],
1014 [N,P,N],
1015 [N,P,P],
1016 [P,N,N],
1017 [P,N,P],
1018 [P,P,N],
1019 [P,P,P],
1020 [P,P,P,P],
1021 [P,P,P,P,P],
1022 [P,P,P,P,P,P],
1023 [P,P,P,P,P,P,P],
1024 [P,P,P,P,P,P,P,P]
1025 ]
1026
1027 genStackFns regstatus args
1028 = genStackApply regstatus args
1029 $$ genStackSave regstatus args
1030
1031
1032 genStackApplyArray types =
1033 vcat [
1034 text "section \"relrodata\" {",
1035 text "stg_ap_stack_entries:",
1036 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
1037 vcat (map arr_ent types),
1038 text "}"
1039 ]
1040 where
1041 arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
1042
1043 genStackSaveArray types =
1044 vcat [
1045 text "section \"relrodata\" {",
1046 text "stg_stack_save_entries:",
1047 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
1048 vcat (map arr_ent types),
1049 text "}"
1050 ]
1051 where
1052 arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
1053
1054 genBitmapArray :: [[ArgRep]] -> Doc
1055 genBitmapArray types =
1056 vcat [
1057 text "section \"rodata\" {",
1058 text "stg_arg_bitmaps:",
1059 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
1060 vcat (map gen_bitmap types),
1061 text "}"
1062 ]
1063 where
1064 gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
1065 where bitmap_val =
1066 (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
1067 .|. sum (map argSize ty)