Implemented and fixed bugs in CmmInfo handling
[ghc.git] / utils / genapply / GenApply.hs
1 {-# OPTIONS -cpp #-}
2 module Main(main) where
3
4 #include "../../includes/ghcconfig.h"
5 #include "../../includes/MachRegs.h"
6 #include "../../includes/Constants.h"
7
8
9 import Text.PrettyPrint
10 import Data.Word
11 import Data.Bits
12 import Data.List ( intersperse )
13 import System.Exit
14 import System.Environment
15 import System.IO
16
17 -- -----------------------------------------------------------------------------
18 -- Argument kinds (rougly equivalent to PrimRep)
19
20 data ArgRep
21 = N -- non-ptr
22 | P -- ptr
23 | V -- void
24 | F -- float
25 | D -- double
26 | L -- long (64-bit)
27
28 -- size of a value in *words*
29 argSize :: ArgRep -> Int
30 argSize N = 1
31 argSize P = 1
32 argSize V = 0
33 argSize F = 1
34 argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
35 argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
36
37 showArg :: ArgRep -> Char
38 showArg N = 'n'
39 showArg P = 'p'
40 showArg V = 'v'
41 showArg F = 'f'
42 showArg D = 'd'
43 showArg L = 'l'
44
45 -- is a value a pointer?
46 isPtr :: ArgRep -> Bool
47 isPtr P = True
48 isPtr _ = False
49
50 -- -----------------------------------------------------------------------------
51 -- Registers
52
53 data RegStatus = Registerised | Unregisterised
54
55 type Reg = String
56
57 availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
58 availableRegs Unregisterised = ([],[],[],[])
59 availableRegs Registerised =
60 ( vanillaRegs MAX_REAL_VANILLA_REG,
61 floatRegs MAX_REAL_FLOAT_REG,
62 doubleRegs MAX_REAL_DOUBLE_REG,
63 longRegs MAX_REAL_LONG_REG
64 )
65
66 vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
67 vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
68 floatRegs n = [ "F" ++ show m | m <- [1..n] ]
69 doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
70 longRegs n = [ "L" ++ show m | m <- [1..n] ]
71
72 -- -----------------------------------------------------------------------------
73 -- Loading/saving register arguments to the stack
74
75 loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
76 loadRegArgs regstatus sp args
77 = (loadRegOffs reg_locs, sp')
78 where (reg_locs, _, sp') = assignRegs regstatus sp args
79
80 loadRegOffs :: [(Reg,Int)] -> Doc
81 loadRegOffs = vcat . map (uncurry assign_stk_to_reg)
82
83 saveRegOffs :: [(Reg,Int)] -> Doc
84 saveRegOffs = vcat . map (uncurry assign_reg_to_stk)
85
86 -- a bit like assignRegs in CgRetConv.lhs
87 assignRegs
88 :: RegStatus -- are we registerised?
89 -> Int -- Sp of first arg
90 -> [ArgRep] -- args
91 -> ([(Reg,Int)], -- regs and offsets to load
92 [ArgRep], -- left-over args
93 Int) -- Sp of left-over args
94 assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
95
96 assign sp [] regs doc = (doc, [], sp)
97 assign sp (V : args) regs doc = assign sp args regs doc
98 assign sp (arg : args) regs doc
99 = case findAvailableReg arg regs of
100 Just (reg, regs') -> assign (sp + argSize arg) args regs'
101 ((reg, sp) : doc)
102 Nothing -> (doc, (arg:args), sp)
103
104 findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
105 Just (vreg, (vregs,fregs,dregs,lregs))
106 findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
107 Just (vreg, (vregs,fregs,dregs,lregs))
108 findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
109 Just (freg, (vregs,fregs,dregs,lregs))
110 findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
111 Just (dreg, (vregs,fregs,dregs,lregs))
112 findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
113 Just (lreg, (vregs,fregs,dregs,lregs))
114 findAvailableReg _ _ = Nothing
115
116 assign_reg_to_stk reg sp
117 = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
118
119 assign_stk_to_reg reg sp
120 = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
121
122 regRep ('F':_) = "F_"
123 regRep ('D':_) = "D_"
124 regRep ('L':_) = "L_"
125 regRep _ = "W_"
126
127 loadSpWordOff :: String -> Int -> Doc
128 loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
129
130 -- make a ptr/non-ptr bitmap from a list of argument types
131 mkBitmap :: [ArgRep] -> Word32
132 mkBitmap args = foldr f 0 args
133 where f arg bm | isPtr arg = bm `shiftL` 1
134 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
135 where size = argSize arg
136
137 -- -----------------------------------------------------------------------------
138 -- Generating the application functions
139
140 -- A SUBTLE POINT about stg_ap functions (can't think of a better
141 -- place to put this comment --SDM):
142 --
143 -- The entry convention to an stg_ap_ function is as follows: all the
144 -- arguments are on the stack (we might revisit this at some point,
145 -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
146 -- EMPTY STACK SLOT at the top of the stack.
147 --
148 -- Why? Because in several cases, stg_ap_* will need an extra stack
149 -- slot, eg. to push a return address in the THUNK case, and this is a
150 -- way of pushing the stack check up into the caller which is probably
151 -- doing one anyway. Allocating the extra stack slot in the caller is
152 -- also probably free, because it will be adjusting Sp after pushing
153 -- the args anyway (this might not be true of register-rich machines
154 -- when we start passing args to stg_ap_* in regs).
155
156 mkApplyName args
157 = text "stg_ap_" <> text (map showArg args)
158
159 mkApplyRetName args
160 = mkApplyName args <> text "_ret"
161
162 mkApplyFastName args
163 = mkApplyName args <> text "_fast"
164
165 mkApplyInfoName args
166 = mkApplyName args <> text "_info"
167
168 genMkPAP regstatus macro jump ticker disamb
169 no_load_regs -- don't load argumnet regs before jumping
170 args_in_regs -- arguments are already in regs
171 is_pap args all_args_size fun_info_label
172 = smaller_arity_cases
173 $$ exact_arity_case
174 $$ larger_arity_case
175
176 where
177 n_args = length args
178
179 -- offset of arguments on the stack at slow apply calls.
180 stk_args_slow_offset = 1
181
182 stk_args_offset
183 | args_in_regs = 0
184 | otherwise = stk_args_slow_offset
185
186 -- The SMALLER ARITY cases:
187 -- if (arity == 1) {
188 -- Sp[0] = Sp[1];
189 -- Sp[1] = (W_)&stg_ap_1_info;
190 -- JMP_(GET_ENTRY(R1.cl));
191 smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
192
193 smaller_arity arity
194 = text "if (arity == " <> int arity <> text ") {" $$
195 nest 4 (vcat [
196 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
197
198 -- load up regs for the call, if necessary
199 load_regs,
200
201 -- If we have more args in registers than are required
202 -- for the call, then we must save some on the stack,
203 -- and set up the stack for the follow-up call.
204 -- If the extra arguments are on the stack, then we must
205 -- instead shuffle them down to make room for the info
206 -- table for the follow-on call.
207 if overflow_regs
208 then save_extra_regs
209 else shuffle_extra_args,
210
211 -- for a PAP, we have to arrange that the stack contains a
212 -- return address in the even that stg_PAP_entry fails its
213 -- heap check. See stg_PAP_entry in Apply.hc for details.
214 if is_pap
215 then text "R2 = " <> mkApplyInfoName this_call_args <> semi
216
217 else empty,
218 text "jump " <> text jump <> semi
219 ]) $$
220 text "}"
221
222 where
223 -- offsets in case we need to save regs:
224 (reg_locs, _, _)
225 = assignRegs regstatus stk_args_offset args
226
227 -- register assignment for *this function call*
228 (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
229 = assignRegs regstatus stk_args_offset (take arity args)
230
231 load_regs
232 | no_load_regs || args_in_regs = empty
233 | otherwise = loadRegOffs reg_locs'
234
235 (this_call_args, rest_args) = splitAt arity args
236
237 -- the offset of the stack args from initial Sp
238 sp_stk_args
239 | args_in_regs = stk_args_offset
240 | no_load_regs = stk_args_offset
241 | otherwise = reg_call_sp_stk_args
242
243 -- the stack args themselves
244 this_call_stack_args
245 | args_in_regs = reg_call_leftovers -- sp offsets are wrong
246 | no_load_regs = this_call_args
247 | otherwise = reg_call_leftovers
248
249 stack_args_size = sum (map argSize this_call_stack_args)
250
251 overflow_regs = args_in_regs && length reg_locs > length reg_locs'
252
253 save_extra_regs
254 = -- we have extra arguments in registers to save
255 let
256 extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
257 adj_reg_locs = [ (reg, off - adj + 1) |
258 (reg,off) <- extra_reg_locs ]
259 adj = case extra_reg_locs of
260 (reg, fst_off):_ -> fst_off
261 size = snd (last adj_reg_locs)
262 in
263 text "Sp_adj(" <> int (-size - 1) <> text ");" $$
264 saveRegOffs adj_reg_locs $$
265 loadSpWordOff "W_" 0 <> text " = " <>
266 mkApplyInfoName rest_args <> semi
267
268 shuffle_extra_args
269 = vcat (map shuffle_down
270 [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
271 loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
272 <> text " = "
273 <> mkApplyInfoName rest_args <> semi $$
274 text "Sp_adj(" <> int (sp_stk_args - 1) <> text ");"
275
276 shuffle_down i =
277 loadSpWordOff "W_" (i-1) <> text " = " <>
278 loadSpWordOff "W_" i <> semi
279
280 -- The EXACT ARITY case
281 --
282 -- if (arity == 1) {
283 -- Sp++;
284 -- JMP_(GET_ENTRY(R1.cl));
285
286 exact_arity_case
287 = text "if (arity == " <> int n_args <> text ") {" $$
288 let
289 (reg_doc, sp')
290 | no_load_regs || args_in_regs = (empty, stk_args_offset)
291 | otherwise = loadRegArgs regstatus stk_args_offset args
292 in
293 nest 4 (vcat [
294 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
295 reg_doc,
296 text "Sp_adj(" <> int sp' <> text ");",
297 if is_pap
298 then text "R2 = " <> fun_info_label <> semi
299 else empty,
300 text "jump " <> text jump <> semi
301 ])
302
303 -- The LARGER ARITY cases:
304 --
305 -- } else /* arity > 1 */ {
306 -- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
307 -- }
308
309 larger_arity_case =
310 text "} else {" $$
311 let
312 save_regs
313 | args_in_regs =
314 text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
315 saveRegOffs reg_locs
316 | otherwise =
317 empty
318 in
319 nest 4 (vcat [
320 -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
321 save_regs,
322 text macro <> char '(' <> int n_args <> comma <>
323 int all_args_size <>
324 text "," <> fun_info_label <>
325 text "," <> text disamb <>
326 text ");"
327 ]) $$
328 char '}'
329 where
330 -- offsets in case we need to save regs:
331 (reg_locs, leftovers, sp_offset)
332 = assignRegs regstatus stk_args_slow_offset args
333 -- BUILD_PAP assumes args start at offset 1
334
335 -- -----------------------------------------------------------------------------
336 -- generate an apply function
337
338 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
339 formalParam :: ArgRep -> Int -> Doc
340 formalParam V _ = empty
341 formalParam arg n =
342 formalParamType arg <> space <>
343 text "arg" <> int n <> text ", "
344 formalParamType arg | isPtr arg = text "\"ptr\"" <> space <> argRep arg
345 | otherwise = argRep arg
346
347 argRep F = text "F_"
348 argRep D = text "D_"
349 argRep L = text "L_"
350 argRep _ = text "W_"
351
352 genApply regstatus args =
353 let
354 fun_ret_label = mkApplyRetName args
355 fun_info_label = mkApplyInfoName args
356 all_args_size = sum (map argSize args)
357 in
358 vcat [
359 text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
360 text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <>
361 text ")\n{",
362 nest 4 (vcat [
363 text "W_ info;",
364 text "W_ arity;",
365
366 -- if fast == 1:
367 -- print "static void *lbls[] ="
368 -- print " { [FUN] &&fun_lbl,"
369 -- print " [FUN_1_0] &&fun_lbl,"
370 -- print " [FUN_0_1] &&fun_lbl,"
371 -- print " [FUN_2_0] &&fun_lbl,"
372 -- print " [FUN_1_1] &&fun_lbl,"
373 -- print " [FUN_0_2] &&fun_lbl,"
374 -- print " [FUN_STATIC] &&fun_lbl,"
375 -- print " [PAP] &&pap_lbl,"
376 -- print " [THUNK] &&thunk_lbl,"
377 -- print " [THUNK_1_0] &&thunk_lbl,"
378 -- print " [THUNK_0_1] &&thunk_lbl,"
379 -- print " [THUNK_2_0] &&thunk_lbl,"
380 -- print " [THUNK_1_1] &&thunk_lbl,"
381 -- print " [THUNK_0_2] &&thunk_lbl,"
382 -- print " [THUNK_STATIC] &&thunk_lbl,"
383 -- print " [THUNK_SELECTOR] &&thunk_lbl,"
384 -- print " [IND] &&ind_lbl,"
385 -- print " [IND_OLDGEN] &&ind_lbl,"
386 -- print " [IND_STATIC] &&ind_lbl,"
387 -- print " [IND_PERM] &&ind_lbl,"
388 -- print " [IND_OLDGEN_PERM] &&ind_lbl"
389 -- print " };"
390
391 text "",
392 text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
393 text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
394
395 text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
396 <> text ")\"ptr\"));",
397
398 -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
399 -- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
400
401 -- text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
402
403 let do_assert [] _ = []
404 do_assert (arg:args) offset
405 | isPtr arg = this : rest
406 | otherwise = rest
407 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
408 <> int offset <> text ")));"
409 rest = do_assert args (offset + argSize arg)
410 in
411 vcat (do_assert args 1),
412
413 text "again:",
414 text "info = %INFO_PTR(R1);",
415
416 -- if fast == 1:
417 -- print " goto *lbls[info->type];";
418 -- else:
419 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
420 nest 4 (vcat [
421
422 -- if fast == 1:
423 -- print " bco_lbl:"
424 -- else:
425 text "case BCO: {",
426 nest 4 (vcat [
427 text "arity = TO_W_(StgBCO_arity(R1));",
428 text "ASSERT(arity > 0);",
429 genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO"
430 True{-stack apply-} False{-args on stack-} False{-not a PAP-}
431 args all_args_size fun_info_label
432 ]),
433 text "}",
434
435 -- if fast == 1:
436 -- print " fun_lbl:"
437 -- else:
438 text "case FUN,",
439 text " FUN_1_0,",
440 text " FUN_0_1,",
441 text " FUN_2_0,",
442 text " FUN_1_1,",
443 text " FUN_0_2,",
444 text " FUN_STATIC: {",
445 nest 4 (vcat [
446 text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
447 text "ASSERT(arity > 0);",
448 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
449 False{-reg apply-} False{-args on stack-} False{-not a PAP-}
450 args all_args_size fun_info_label
451 ]),
452 text "}",
453
454 -- if fast == 1:
455 -- print " pap_lbl:"
456 -- else:
457
458 text "case PAP: {",
459 nest 4 (vcat [
460 text "arity = TO_W_(StgPAP_arity(R1));",
461 text "ASSERT(arity > 0);",
462 genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP"
463 True{-stack apply-} False{-args on stack-} True{-is a PAP-}
464 args all_args_size fun_info_label
465 ]),
466 text "}",
467
468 text "",
469
470 -- if fast == 1:
471 -- print " thunk_lbl:"
472 -- else:
473 text "case AP,",
474 text " AP_STACK,",
475 text " CAF_BLACKHOLE,",
476 text " BLACKHOLE,",
477 text " SE_BLACKHOLE,",
478 text " SE_CAF_BLACKHOLE,",
479 text " THUNK,",
480 text " THUNK_1_0,",
481 text " THUNK_0_1,",
482 text " THUNK_2_0,",
483 text " THUNK_1_1,",
484 text " THUNK_0_2,",
485 text " THUNK_STATIC,",
486 text " THUNK_SELECTOR: {",
487 nest 4 (vcat [
488 -- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
489 text "Sp(0) = " <> fun_info_label <> text ";",
490 -- CAREFUL! in SMP mode, the info table may already have been
491 -- overwritten by an indirection, so we must enter the original
492 -- info pointer we read, don't read it again, because it might
493 -- not be enterable any more.
494 text "jump %ENTRY_CODE(info);",
495 text ""
496 ]),
497 text "}",
498
499 -- if fast == 1:
500 -- print " ind_lbl:"
501 -- else:
502 text "case IND,",
503 text " IND_OLDGEN,",
504 text " IND_STATIC,",
505 text " IND_PERM,",
506 text " IND_OLDGEN_PERM: {",
507 nest 4 (vcat [
508 text "R1 = StgInd_indirectee(R1);",
509 text "goto again;"
510 ]),
511 text "}",
512 text "",
513
514 -- if fast == 0:
515
516 text "default: {",
517 nest 4 (
518 text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");"
519 ),
520 text "}"
521
522 ]),
523 text "}"
524 ]),
525 text "}"
526 ]
527
528 -- -----------------------------------------------------------------------------
529 -- Making a fast unknown application, args are in regs
530
531 genApplyFast regstatus args =
532 let
533 fun_fast_label = mkApplyFastName args
534 fun_ret_label = text "RET_LBL" <> parens (mkApplyName args)
535 fun_info_label = mkApplyInfoName args
536 all_args_size = sum (map argSize args)
537 in
538 vcat [
539 fun_fast_label,
540 char '{',
541 nest 4 (vcat [
542 text "W_ info;",
543 text "W_ arity;",
544 text "info = %GET_STD_INFO(R1);",
545 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
546 nest 4 (vcat [
547 text "case FUN,",
548 text " FUN_1_0,",
549 text " FUN_0_1,",
550 text " FUN_2_0,",
551 text " FUN_1_1,",
552 text " FUN_0_2,",
553 text " FUN_STATIC: {",
554 nest 4 (vcat [
555 text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
556 text "ASSERT(arity > 0);",
557 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
558 False{-reg apply-} True{-args in regs-} False{-not a PAP-}
559 args all_args_size fun_info_label
560 ]),
561 char '}',
562
563 text "default: {",
564 let
565 (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
566 -- leave a one-word space on the top of the stack when
567 -- calling the slow version
568 in
569 nest 4 (vcat [
570 text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
571 saveRegOffs reg_locs,
572 text "jump" <+> fun_ret_label <> semi
573 ]),
574 char '}'
575 ]),
576 char '}'
577 ]),
578 char '}'
579 ]
580
581 -- -----------------------------------------------------------------------------
582 -- Making a stack apply
583
584 -- These little functions are like slow entry points. They provide
585 -- the layer between the PAP entry code and the function's fast entry
586 -- point: namely they load arguments off the stack into registers (if
587 -- available) and jump to the function's entry code.
588 --
589 -- On entry: R1 points to the function closure
590 -- arguments are on the stack starting at Sp
591 --
592 -- Invariant: the list of arguments never contains void. Since we're only
593 -- interested in loading arguments off the stack here, we can ignore
594 -- void arguments.
595
596 mkStackApplyEntryLabel:: [ArgRep] -> Doc
597 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
598
599 genStackApply :: RegStatus -> [ArgRep] -> Doc
600 genStackApply regstatus args =
601 let fn_entry_label = mkStackApplyEntryLabel args in
602 vcat [
603 fn_entry_label,
604 text "{", nest 4 body, text "}"
605 ]
606 where
607 (assign_regs, sp') = loadRegArgs regstatus 0 args
608 body = vcat [assign_regs,
609 text "Sp_adj" <> parens (int sp') <> semi,
610 text "jump %GET_ENTRY(R1);"
611 ]
612
613 -- -----------------------------------------------------------------------------
614 -- Stack save entry points.
615 --
616 -- These code fragments are used to save registers on the stack at a heap
617 -- check failure in the entry code for a function. We also have to save R1
618 -- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
619 -- in HeapStackCheck.hc for more details.
620
621 mkStackSaveEntryLabel :: [ArgRep] -> Doc
622 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
623
624 genStackSave :: RegStatus -> [ArgRep] -> Doc
625 genStackSave regstatus args =
626 let fn_entry_label= mkStackSaveEntryLabel args in
627 vcat [
628 fn_entry_label,
629 text "{", nest 4 body, text "}"
630 ]
631 where
632 body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
633 saveRegOffs reg_locs,
634 text "Sp(2) = R1;",
635 text "Sp(1) =" <+> int stk_args <> semi,
636 text "Sp(0) = stg_gc_fun_info;",
637 text "jump stg_gc_noregs;"
638 ]
639
640 std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
641 -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
642 (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
643
644 -- number of words of arguments on the stack.
645 stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
646
647 -- -----------------------------------------------------------------------------
648 -- The prologue...
649
650 main = do
651 args <- getArgs
652 regstatus <- case args of
653 [] -> return Registerised
654 ["-u"] -> return Unregisterised
655 _other -> do hPutStrLn stderr "syntax: genapply [-u]"
656 exitWith (ExitFailure 1)
657 let the_code = vcat [
658 text "// DO NOT EDIT!",
659 text "// Automatically generated by GenApply.hs",
660 text "",
661 text "#include \"Cmm.h\"",
662 text "#include \"AutoApply.h\"",
663 text "",
664
665 vcat (intersperse (text "") $
666 map (genApply regstatus) applyTypes),
667 vcat (intersperse (text "") $
668 map (genStackFns regstatus) stackApplyTypes),
669
670 vcat (intersperse (text "") $
671 map (genApplyFast regstatus) applyTypes),
672
673 genStackApplyArray stackApplyTypes,
674 genStackSaveArray stackApplyTypes,
675 genBitmapArray stackApplyTypes,
676
677 text "" -- add a newline at the end of the file
678 ]
679 -- in
680 putStr (render the_code)
681
682 -- These have been shown to cover about 99% of cases in practice...
683 applyTypes = [
684 [V],
685 [F],
686 [D],
687 [L],
688 [N],
689 [P],
690 [P,V],
691 [P,P],
692 [P,P,V],
693 [P,P,P],
694 [P,P,P,V],
695 [P,P,P,P],
696 [P,P,P,P,P],
697 [P,P,P,P,P,P]
698 ]
699
700 -- No need for V args in the stack apply cases.
701 -- ToDo: the stack apply and stack save code doesn't make a distinction
702 -- between N and P (they both live in the same register), only the bitmap
703 -- changes, so we could share the apply/save code between lots of cases.
704 stackApplyTypes = [
705 [],
706 [N],
707 [P],
708 [F],
709 [D],
710 [L],
711 [N,N],
712 [N,P],
713 [P,N],
714 [P,P],
715 [N,N,N],
716 [N,N,P],
717 [N,P,N],
718 [N,P,P],
719 [P,N,N],
720 [P,N,P],
721 [P,P,N],
722 [P,P,P],
723 [P,P,P,P],
724 [P,P,P,P,P],
725 [P,P,P,P,P,P],
726 [P,P,P,P,P,P,P],
727 [P,P,P,P,P,P,P,P]
728 ]
729
730 genStackFns regstatus args
731 = genStackApply regstatus args
732 $$ genStackSave regstatus args
733
734
735 genStackApplyArray types =
736 vcat [
737 text "section \"relrodata\" {",
738 text "stg_ap_stack_entries:",
739 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
740 vcat (map arr_ent types),
741 text "}"
742 ]
743 where
744 arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
745
746 genStackSaveArray types =
747 vcat [
748 text "section \"relrodata\" {",
749 text "stg_stack_save_entries:",
750 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
751 vcat (map arr_ent types),
752 text "}"
753 ]
754 where
755 arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
756
757 genBitmapArray :: [[ArgRep]] -> Doc
758 genBitmapArray types =
759 vcat [
760 text "section \"rodata\" {",
761 text "stg_arg_bitmaps:",
762 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
763 vcat (map gen_bitmap types),
764 text "}"
765 ]
766 where
767 gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
768 where bitmap_val =
769 (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
770 .|. sum (map argSize ty)
771