2 module Main(main) where
4 #include "../../includes/config.h"
5 #include "../../includes/MachRegs.h"
7 #if __GLASGOW_HASKELL__ >= 504
8 import Text.PrettyPrint
11 import Data.List ( intersperse )
12 import Data.Char ( toUpper )
17 import List ( intersperse )
18 import Char ( toUpper )
22 -- -----------------------------------------------------------------------------
23 -- Argument kinds (rougly equivalent to PrimRep)
33 -- size of a value in *words*
34 argSize :: ArgRep -> Int
39 argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
40 argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
42 showArg :: ArgRep -> Char
50 -- is a value a pointer?
51 isPtr :: ArgRep -> Bool
55 -- -----------------------------------------------------------------------------
60 availableRegs :: ([Reg],[Reg],[Reg],[Reg])
62 ( vanillaRegs MAX_REAL_VANILLA_REG,
63 floatRegs MAX_REAL_FLOAT_REG,
64 doubleRegs MAX_REAL_DOUBLE_REG,
65 longRegs MAX_REAL_LONG_REG
68 vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
69 vanillaRegs n = [ "R" ++ show m ++ ".w" | m <- [2..n] ] -- never use R1
70 floatRegs n = [ "F" ++ show m | m <- [1..n] ]
71 doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
72 longRegs n = [ "L" ++ show m | m <- [1..n] ]
74 -- -----------------------------------------------------------------------------
75 -- Loading/saving register arguments to the stack
77 loadRegArgs :: Int -> [ArgRep] -> (Doc,Int)
78 loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
80 (reg_locs, sp') = assignRegs sp args
82 -- a bit like assignRegs in CgRetConv.lhs
84 :: Int -- Sp of first arg
86 -> ([(Reg,Int)], Int) -- Sp and rest of args
87 assignRegs sp args = assign sp args availableRegs []
89 assign sp [] regs doc = (doc, sp)
90 assign sp (V : args) regs doc = assign sp args regs doc
91 assign sp (arg : args) regs doc
92 = case findAvailableReg arg regs of
93 Just (reg, regs') -> assign (sp + argSize arg) args regs'
97 findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
98 Just (vreg, (vregs,fregs,dregs,lregs))
99 findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
100 Just (vreg, (vregs,fregs,dregs,lregs))
101 findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
102 Just (freg, (vregs,fregs,dregs,lregs))
103 findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
104 Just (dreg, (vregs,fregs,dregs,lregs))
105 findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
106 Just (lreg, (vregs,fregs,dregs,lregs))
107 findAvailableReg _ _ = Nothing
109 assign_reg_to_stk reg@('F':_) sp
110 = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");"
111 assign_reg_to_stk reg@('D':_) sp
112 = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");"
113 assign_reg_to_stk reg@('L':_) sp
114 = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");"
115 assign_reg_to_stk reg sp
116 = text "Sp[" <> int sp <> text "] = " <> text reg <> semi
118 assign_stk_to_reg reg@('F':_) sp
119 = text reg <> text " = " <> text "PK_FLT(Sp+" <> int sp <> text ");"
120 assign_stk_to_reg reg@('D':_) sp
121 = text reg <> text " = " <> text "PK_DBL(Sp+" <> int sp <> text ");"
122 assign_stk_to_reg reg@('L':_) sp
123 = text reg <> text " = " <> text "PK_Word64(Sp+" <> int sp <> text ");"
124 assign_stk_to_reg reg sp
125 = text reg <> text " = Sp[" <> int sp <> text "];"
128 -- make a ptr/non-ptr bitmap from a list of argument types
129 mkBitmap :: [ArgRep] -> Word32
130 mkBitmap args = foldr f 0 args
131 where f arg bm | isPtr arg = bm `shiftL` 1
132 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
133 where size = argSize arg
135 -- -----------------------------------------------------------------------------
136 -- Generating the application functions
138 -- A SUBTLE POINT about stg_ap functions (can't think of a better
139 -- place to put this comment --SDM):
141 -- The entry convention to an stg_ap_ function is as follows: all the
142 -- arguments are on the stack (we might revisit this at some point,
143 -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
144 -- EMPTY STACK SLOT at the top of the stack.
146 -- Why? Because in several cases, stg_ap_* will need an extra stack
147 -- slot, eg. to push a return address in the THUNK case, and this is a
148 -- way of pushing the stack check up into the caller which is probably
149 -- doing one anyway. Allocating the extra stack slot in the caller is
150 -- also probably free, because it will be adjusting Sp after pushing
151 -- the args anyway (this might not be true of register-rich machines
152 -- when we start passing args to stg_ap_* in regs).
155 = text "stg_ap_" <> text (map showArg args) <> text "_ret"
158 = text "stg_ap_" <> text (map showArg args) <> text "_info"
160 genMkPAP macro jump stack_apply is_pap args all_args_size fun_info_label
161 = smaller_arity_cases
168 -- offset of args on the stack, see large comment above.
171 -- The SMALLER ARITY cases:
174 -- Sp[1] = (W_)&stg_ap_1_info;
175 -- JMP_(GET_ENTRY(R1.cl));
177 smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
180 = text "if (arity == " <> int arity <> text ") {" $$
183 | stack_apply = (empty, arg_sp_offset)
184 | otherwise = loadRegArgs arg_sp_offset these_args
188 vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
189 text "Sp[" <> int these_args_size <> text "] = (W_)&" <>
190 mkApplyInfoName rest_args <> semi,
191 text "Sp += " <> int (sp' - 1) <> semi,
192 -- for a PAP, we have to arrange that the stack contains a
193 -- return address in the even that stg_PAP_entry fails its
194 -- heap check. See stg_PAP_entry in Apply.hc for details.
196 then text "R2.w = (W_)&" <> mkApplyInfoName these_args <> semi
198 text "JMP_" <> parens (text jump) <> semi
202 (these_args, rest_args) = splitAt arity args
203 these_args_size = sum (map argSize these_args)
206 text "Sp[" <> int (i-1) <> text "] = Sp["
207 <> int i <> text "];"
209 -- The EXACT ARITY case
213 -- JMP_(GET_ENTRY(R1.cl));
216 = text "if (arity == " <> int n_args <> text ") {" $$
219 | stack_apply = (empty, arg_sp_offset)
220 | otherwise = loadRegArgs arg_sp_offset args
224 text "Sp += " <> int sp' <> semi,
226 then text "R2.w = (W_)&" <> fun_info_label <> semi
228 text "JMP_" <> parens (text jump) <> semi
231 -- The LARGER ARITY cases:
233 -- } else /* arity > 1 */ {
234 -- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
240 text macro <> char '(' <> int n_args <> comma <>
242 text ",(W_)&" <> fun_info_label <>
247 -- -----------------------------------------------------------------------------
248 -- generate an apply function
250 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
254 fun_ret_label = mkApplyRetName args
255 fun_info_label = mkApplyInfoName args
256 all_args_size = sum (map argSize args)
259 text "INFO_TABLE_RET(" <> fun_info_label <> text "," <>
260 fun_ret_label <> text "," <>
261 text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <>
262 int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <>
263 text "0,0,0,RET_SMALL,,EF_,0,0);",
265 text "F_ " <> fun_ret_label <> text "( void )\n{",
267 text "StgInfoTable *info;",
271 -- print "static void *lbls[] ="
272 -- print " { [FUN] &&fun_lbl,"
273 -- print " [FUN_1_0] &&fun_lbl,"
274 -- print " [FUN_0_1] &&fun_lbl,"
275 -- print " [FUN_2_0] &&fun_lbl,"
276 -- print " [FUN_1_1] &&fun_lbl,"
277 -- print " [FUN_0_2] &&fun_lbl,"
278 -- print " [FUN_STATIC] &&fun_lbl,"
279 -- print " [PAP] &&pap_lbl,"
280 -- print " [THUNK] &&thunk_lbl,"
281 -- print " [THUNK_1_0] &&thunk_lbl,"
282 -- print " [THUNK_0_1] &&thunk_lbl,"
283 -- print " [THUNK_2_0] &&thunk_lbl,"
284 -- print " [THUNK_1_1] &&thunk_lbl,"
285 -- print " [THUNK_0_2] &&thunk_lbl,"
286 -- print " [THUNK_STATIC] &&thunk_lbl,"
287 -- print " [THUNK_SELECTOR] &&thunk_lbl,"
288 -- print " [IND] &&ind_lbl,"
289 -- print " [IND_OLDGEN] &&ind_lbl,"
290 -- print " [IND_STATIC] &&ind_lbl,"
291 -- print " [IND_PERM] &&ind_lbl,"
292 -- print " [IND_OLDGEN_PERM] &&ind_lbl"
297 text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <>
298 text "... \"); printClosure(R1.cl));",
300 text "IF_DEBUG(sanity,checkStackFrame(Sp+" <> int (1 + all_args_size)
303 -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
304 -- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
306 text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
308 let do_assert [] _ = []
309 do_assert (arg:args) offset
310 | isPtr arg = this : rest
312 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp["
313 <> int offset <> text "]));"
314 rest = do_assert args (offset + argSize arg)
316 vcat (do_assert args 1),
319 text "info = get_itbl(R1.cl);",
322 -- print " goto *lbls[info->type];";
324 text "switch (info->type) {" $$
332 text "arity = ((StgBCO *)R1.p)->arity;",
333 text "ASSERT(arity > 0);",
334 genMkPAP "BUILD_PAP" "stg_BCO_entry"
335 True{-stack apply-} False{-not a PAP-}
336 args all_args_size fun_info_label
343 text "case FUN_1_0:",
344 text "case FUN_0_1:",
345 text "case FUN_2_0:",
346 text "case FUN_1_1:",
347 text "case FUN_0_2:",
348 text "case FUN_STATIC:",
350 text "arity = itbl_to_fun_itbl(info)->arity;",
351 text "ASSERT(arity > 0);",
352 genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)"
353 False{-reg apply-} False{-not a PAP-}
354 args all_args_size fun_info_label
363 text "arity = ((StgPAP *)R1.p)->arity;",
364 text "ASSERT(arity > 0);",
365 genMkPAP "NEW_PAP" "stg_PAP_entry"
366 True{-stack apply-} True{-is a PAP-}
367 args all_args_size fun_info_label
373 -- print " thunk_lbl:"
376 text "case AP_STACK:",
377 text "case CAF_BLACKHOLE:",
378 text "case BLACKHOLE:",
379 text "case BLACKHOLE_BQ:",
380 text "case SE_BLACKHOLE:",
381 text "case SE_CAF_BLACKHOLE:",
383 text "case THUNK_1_0:",
384 text "case THUNK_0_1:",
385 text "case THUNK_2_0:",
386 text "case THUNK_1_1:",
387 text "case THUNK_0_2:",
388 text "case THUNK_STATIC:",
389 text "case THUNK_SELECTOR:",
391 text "Sp[0] = (W_)&" <> fun_info_label <> text ";",
392 text "JMP_(GET_ENTRY(R1.cl));",
400 text "case IND_OLDGEN:",
401 text "case IND_STATIC:",
402 text "case IND_PERM:",
403 text "case IND_OLDGEN_PERM:",
405 text "R1.cl = ((StgInd *)R1.p)->indirectee;",
414 text "barf(\"" <> fun_ret_label <> text "\");"
424 -- -----------------------------------------------------------------------------
425 -- Making a stack apply
427 -- These little functions are like slow entry points. They provide
428 -- the layer between the PAP entry code and the function's fast entry
429 -- point: namely they load arguments off the stack into registers (if
430 -- available) and jump to the function's entry code.
432 -- On entry: R1 points to the function closure
433 -- arguments are on the stack starting at Sp
435 -- Invariant: the list of arguments never contains void. Since we're only
436 -- interested in loading arguments off the stack here, we can ignore
439 mkStackApplyEntryLabel:: [ArgRep] -> Doc
440 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
442 genStackApply :: [ArgRep] -> Doc
444 let fn_entry_label = mkStackApplyEntryLabel args in
446 text "IF_" <> parens fn_entry_label,
448 nest 4 (text "FB_" $$ body $$ text "FE_"),
452 (assign_regs, sp') = loadRegArgs 0 args
453 body = vcat [assign_regs,
454 text "Sp += " <> int sp' <> semi,
455 text "JMP_(GET_ENTRY(R1.cl));"
458 -- -----------------------------------------------------------------------------
459 -- Stack save entry points.
461 -- These code fragments are used to save registers on the stack at a heap
462 -- check failure in the entry code for a function. We also have to save R1
463 -- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
464 -- in HeapStackCheck.hc for more details.
466 mkStackSaveEntryLabel :: [ArgRep] -> Doc
467 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
469 genStackSave :: [ArgRep] -> Doc
471 let fn_entry_label= mkStackSaveEntryLabel args in
473 text "IF_" <> parens fn_entry_label,
475 nest 4 (text "FB_" $$ body $$ text "FE_"),
479 body = vcat [text "Sp -= " <> int sp_offset <> semi,
480 vcat (map (uncurry assign_reg_to_stk) reg_locs),
481 text "Sp[2] = R1.w;",
482 text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi,
483 text "Sp[0] = (W_)&stg_gc_fun_info;",
484 text "JMP_(stg_gc_noregs);"
487 std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
488 -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
489 (reg_locs, sp_offset) = assignRegs std_frame_size args
491 -- -----------------------------------------------------------------------------
494 main = putStr (render the_code)
495 where the_code = vcat [
496 text "// DO NOT EDIT!",
497 text "// Automatically generated by GenApply.hs",
499 text "#include \"Stg.h\"",
500 text "#include \"Rts.h\"",
501 text "#include \"RtsFlags.h\"",
502 text "#include \"Storage.h\"",
503 text "#include \"RtsUtils.h\"",
504 text "#include \"Printer.h\"",
505 text "#include \"Sanity.h\"",
506 text "#include \"Apply.h\"",
508 text "#include <stdio.h>",
510 vcat (intersperse (text "") $ map genApply applyTypes),
511 vcat (intersperse (text "") $ map genStackFns stackApplyTypes),
513 genStackApplyArray stackApplyTypes,
514 genStackSaveArray stackApplyTypes,
515 genBitmapArray stackApplyTypes,
517 text "" -- add a newline at the end of the file
520 -- These have been shown to cover about 99% of cases in practice...
538 -- No need for V args in the stack apply cases.
539 -- ToDo: the stack apply and stack save code doesn't make a distinction
540 -- between N and P (they both live in the same register), only the bitmap
541 -- changes, so we could share the apply/save code between lots of cases.
567 genStackFns args = genStackApply args $$ genStackSave args
570 genStackApplyArray types =
571 text "StgFun *stg_ap_stack_entries[] = {" $$
572 vcat (map arr_ent types) $$
575 arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma
577 genStackSaveArray types =
578 text "StgFun *stg_stack_save_entries[] = {" $$
579 vcat (map arr_ent types) $$
582 arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma
584 genBitmapArray :: [[ArgRep]] -> Doc
585 genBitmapArray types =
587 text "StgWord stg_arg_bitmaps[] = {",
588 vcat (map gen_bitmap types),
592 gen_bitmap ty = brackets (arg_const ty) <+>
593 text "MK_SMALL_BITMAP" <> parens (
594 int (sum (map argSize ty)) <> comma <>
595 text (show (mkBitmap ty))) <>
598 arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty))