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