2 module Main(main) where
4 #include "../../includes/ghcconfig.h"
5 #include "../../includes/MachRegs.h"
6 #include "../../includes/Constants.h"
9 #if __GLASGOW_HASKELL__ >= 504
10 import Text.PrettyPrint
13 import Data.List ( intersperse )
15 import System.Environment
23 import List ( intersperse )
26 -- -----------------------------------------------------------------------------
27 -- Argument kinds (rougly equivalent to PrimRep)
37 -- size of a value in *words*
38 argSize :: ArgRep -> Int
43 argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
44 argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
46 showArg :: ArgRep -> Char
54 -- is a value a pointer?
55 isPtr :: ArgRep -> Bool
59 -- -----------------------------------------------------------------------------
62 data RegStatus = Registerised | Unregisterised
66 availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
67 availableRegs Unregisterised = ([],[],[],[])
68 availableRegs Registerised =
69 ( vanillaRegs MAX_REAL_VANILLA_REG,
70 floatRegs MAX_REAL_FLOAT_REG,
71 doubleRegs MAX_REAL_DOUBLE_REG,
72 longRegs MAX_REAL_LONG_REG
75 vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
76 vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
77 floatRegs n = [ "F" ++ show m | m <- [1..n] ]
78 doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
79 longRegs n = [ "L" ++ show m | m <- [1..n] ]
81 -- -----------------------------------------------------------------------------
82 -- Loading/saving register arguments to the stack
84 loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
85 loadRegArgs regstatus sp args
86 = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
88 (reg_locs, _leftovers, sp') = assignRegs regstatus sp args
90 -- a bit like assignRegs in CgRetConv.lhs
92 :: RegStatus -- are we registerised?
93 -> Int -- Sp of first arg
95 -> ([(Reg,Int)], -- regs and offsets to load
96 [ArgRep], -- left-over args
97 Int) -- Sp of left-over args
98 assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
100 assign sp [] regs doc = (doc, [], sp)
101 assign sp (V : args) regs doc = assign sp args regs doc
102 assign sp (arg : args) regs doc
103 = case findAvailableReg arg regs of
104 Just (reg, regs') -> assign (sp + argSize arg) args regs'
106 Nothing -> (doc, (arg:args), sp)
108 findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
109 Just (vreg, (vregs,fregs,dregs,lregs))
110 findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
111 Just (vreg, (vregs,fregs,dregs,lregs))
112 findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
113 Just (freg, (vregs,fregs,dregs,lregs))
114 findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
115 Just (dreg, (vregs,fregs,dregs,lregs))
116 findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
117 Just (lreg, (vregs,fregs,dregs,lregs))
118 findAvailableReg _ _ = Nothing
120 assign_reg_to_stk reg sp
121 = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
123 assign_stk_to_reg reg sp
124 = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
126 regRep ('F':_) = "F_"
127 regRep ('D':_) = "D_"
128 regRep ('L':_) = "L_"
131 loadSpWordOff :: String -> Int -> Doc
132 loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
134 -- make a ptr/non-ptr bitmap from a list of argument types
135 mkBitmap :: [ArgRep] -> Word32
136 mkBitmap args = foldr f 0 args
137 where f arg bm | isPtr arg = bm `shiftL` 1
138 | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
139 where size = argSize arg
141 -- -----------------------------------------------------------------------------
142 -- Generating the application functions
144 -- A SUBTLE POINT about stg_ap functions (can't think of a better
145 -- place to put this comment --SDM):
147 -- The entry convention to an stg_ap_ function is as follows: all the
148 -- arguments are on the stack (we might revisit this at some point,
149 -- but it doesn't make any difference on x86), and THERE IS AN EXTRA
150 -- EMPTY STACK SLOT at the top of the stack.
152 -- Why? Because in several cases, stg_ap_* will need an extra stack
153 -- slot, eg. to push a return address in the THUNK case, and this is a
154 -- way of pushing the stack check up into the caller which is probably
155 -- doing one anyway. Allocating the extra stack slot in the caller is
156 -- also probably free, because it will be adjusting Sp after pushing
157 -- the args anyway (this might not be true of register-rich machines
158 -- when we start passing args to stg_ap_* in regs).
161 = text "stg_ap_" <> text (map showArg args)
164 = mkApplyName args <> text "_ret"
167 = mkApplyName args <> text "_info"
169 genMkPAP regstatus macro jump ticker disamb stack_apply
170 is_pap args all_args_size fun_info_label
171 = smaller_arity_cases
178 -- offset of args on the stack, see large comment above.
181 -- The SMALLER ARITY cases:
184 -- Sp[1] = (W_)&stg_ap_1_info;
185 -- JMP_(GET_ENTRY(R1.cl));
187 smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
190 = text "if (arity == " <> int arity <> text ") {" $$
193 | stack_apply = (empty, arg_sp_offset)
194 | otherwise = loadRegArgs regstatus arg_sp_offset these_args
197 text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
199 vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
200 loadSpWordOff "W_" these_args_size <> text " = " <>
201 mkApplyInfoName rest_args <> semi,
202 text "Sp_adj(" <> int (sp' - 1) <> text ");",
203 -- for a PAP, we have to arrange that the stack contains a
204 -- return address in the even that stg_PAP_entry fails its
205 -- heap check. See stg_PAP_entry in Apply.hc for details.
207 then text "R2 = " <> mkApplyInfoName these_args <> semi
209 text "jump " <> text jump <> semi
213 (these_args, rest_args) = splitAt arity args
214 these_args_size = sum (map argSize these_args)
217 loadSpWordOff "W_" (i-1) <> text " = " <>
218 loadSpWordOff "W_" i <> semi
220 -- The EXACT ARITY case
224 -- JMP_(GET_ENTRY(R1.cl));
227 = text "if (arity == " <> int n_args <> text ") {" $$
230 | stack_apply = (empty, arg_sp_offset)
231 | otherwise = loadRegArgs regstatus arg_sp_offset args
234 text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
236 text "Sp_adj(" <> int sp' <> text ");",
238 then text "R2 = " <> fun_info_label <> semi
240 text "jump " <> text jump <> semi
243 -- The LARGER ARITY cases:
245 -- } else /* arity > 1 */ {
246 -- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
252 text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
253 text macro <> char '(' <> int n_args <> comma <>
255 text "," <> fun_info_label <>
256 text "," <> text disamb <>
261 -- -----------------------------------------------------------------------------
262 -- generate an apply function
264 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
266 genApply regstatus args =
268 fun_ret_label = mkApplyRetName args
269 fun_info_label = mkApplyInfoName args
270 all_args_size = sum (map argSize args)
273 text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
274 int all_args_size <> text "/*framsize*/," <>
275 int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <>
276 text "RET_SMALL)\n{",
282 -- print "static void *lbls[] ="
283 -- print " { [FUN] &&fun_lbl,"
284 -- print " [FUN_1_0] &&fun_lbl,"
285 -- print " [FUN_0_1] &&fun_lbl,"
286 -- print " [FUN_2_0] &&fun_lbl,"
287 -- print " [FUN_1_1] &&fun_lbl,"
288 -- print " [FUN_0_2] &&fun_lbl,"
289 -- print " [FUN_STATIC] &&fun_lbl,"
290 -- print " [PAP] &&pap_lbl,"
291 -- print " [THUNK] &&thunk_lbl,"
292 -- print " [THUNK_1_0] &&thunk_lbl,"
293 -- print " [THUNK_0_1] &&thunk_lbl,"
294 -- print " [THUNK_2_0] &&thunk_lbl,"
295 -- print " [THUNK_1_1] &&thunk_lbl,"
296 -- print " [THUNK_0_2] &&thunk_lbl,"
297 -- print " [THUNK_STATIC] &&thunk_lbl,"
298 -- print " [THUNK_SELECTOR] &&thunk_lbl,"
299 -- print " [IND] &&ind_lbl,"
300 -- print " [IND_OLDGEN] &&ind_lbl,"
301 -- print " [IND_STATIC] &&ind_lbl,"
302 -- print " [IND_PERM] &&ind_lbl,"
303 -- print " [IND_OLDGEN_PERM] &&ind_lbl"
307 text "IF_DEBUG(apply,foreign \"C\" fprintf(stderr, \"" <> fun_ret_label <>
308 text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
310 text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
311 <> text ")\"ptr\"));",
313 -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
314 -- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
316 text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
318 let do_assert [] _ = []
319 do_assert (arg:args) offset
320 | isPtr arg = this : rest
322 where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
323 <> int offset <> text ")));"
324 rest = do_assert args (offset + argSize arg)
326 vcat (do_assert args 1),
329 text "info = %GET_STD_INFO(R1);",
332 -- print " goto *lbls[info->type];";
334 text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(info)) {",
342 text "arity = TO_W_(StgBCO_arity(R1));",
343 text "ASSERT(arity > 0);",
344 genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO"
345 True{-stack apply-} False{-not a PAP-}
346 args all_args_size fun_info_label
359 text " FUN_STATIC: {",
361 text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
362 text "ASSERT(arity > 0);",
363 genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
364 False{-reg apply-} False{-not a PAP-}
365 args all_args_size fun_info_label
375 text "arity = TO_W_(StgPAP_arity(R1));",
376 text "ASSERT(arity > 0);",
377 genMkPAP regstatus "NEW_PAP" "ENTRY_LBL(stg_PAP)" "PAP" "PAP"
378 True{-stack apply-} True{-is a PAP-}
379 args all_args_size fun_info_label
386 -- print " thunk_lbl:"
390 text " CAF_BLACKHOLE,",
392 text " BLACKHOLE_BQ,",
393 text " SE_BLACKHOLE,",
394 text " SE_CAF_BLACKHOLE,",
401 text " THUNK_STATIC,",
402 text " THUNK_SELECTOR: {",
404 text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
405 text "Sp(0) = " <> fun_info_label <> text ";",
406 text "jump %GET_ENTRY(R1);",
418 text " IND_OLDGEN_PERM: {",
420 text "R1 = StgInd_indirectee(R1);",
430 text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");"
440 -- -----------------------------------------------------------------------------
441 -- Making a stack apply
443 -- These little functions are like slow entry points. They provide
444 -- the layer between the PAP entry code and the function's fast entry
445 -- point: namely they load arguments off the stack into registers (if
446 -- available) and jump to the function's entry code.
448 -- On entry: R1 points to the function closure
449 -- arguments are on the stack starting at Sp
451 -- Invariant: the list of arguments never contains void. Since we're only
452 -- interested in loading arguments off the stack here, we can ignore
455 mkStackApplyEntryLabel:: [ArgRep] -> Doc
456 mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
458 genStackApply :: RegStatus -> [ArgRep] -> Doc
459 genStackApply regstatus args =
460 let fn_entry_label = mkStackApplyEntryLabel args in
463 text "{", nest 4 body, text "}"
466 (assign_regs, sp') = loadRegArgs regstatus 0 args
467 body = vcat [assign_regs,
468 text "Sp_adj" <> parens (int sp') <> semi,
469 text "jump %GET_ENTRY(R1);"
472 -- -----------------------------------------------------------------------------
473 -- Stack save entry points.
475 -- These code fragments are used to save registers on the stack at a heap
476 -- check failure in the entry code for a function. We also have to save R1
477 -- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
478 -- in HeapStackCheck.hc for more details.
480 mkStackSaveEntryLabel :: [ArgRep] -> Doc
481 mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
483 genStackSave :: RegStatus -> [ArgRep] -> Doc
484 genStackSave regstatus args =
485 let fn_entry_label= mkStackSaveEntryLabel args in
488 text "{", nest 4 body, text "}"
491 body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
492 vcat (map (uncurry assign_reg_to_stk) reg_locs),
494 text "Sp(1) =" <+> int stk_args <> semi,
495 text "Sp(0) = stg_gc_fun_info;",
496 text "jump stg_gc_noregs;"
499 std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
500 -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
501 (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
503 -- number of words of arguments on the stack.
504 stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
506 -- -----------------------------------------------------------------------------
511 regstatus <- case args of
512 [] -> return Registerised
513 ["-u"] -> return Unregisterised
514 _other -> do hPutStrLn stderr "syntax: genapply [-u]"
515 exitWith (ExitFailure 1)
516 let the_code = vcat [
517 text "// DO NOT EDIT!",
518 text "// Automatically generated by GenApply.hs",
520 text "#include \"Cmm.h\"",
521 text "#include \"AutoApply.h\"",
524 vcat (intersperse (text "") $
525 map (genApply regstatus) applyTypes),
526 vcat (intersperse (text "") $
527 map (genStackFns regstatus) stackApplyTypes),
529 genStackApplyArray stackApplyTypes,
530 genStackSaveArray stackApplyTypes,
531 genBitmapArray stackApplyTypes,
533 text "" -- add a newline at the end of the file
536 putStr (render the_code)
538 -- These have been shown to cover about 99% of cases in practice...
556 -- No need for V args in the stack apply cases.
557 -- ToDo: the stack apply and stack save code doesn't make a distinction
558 -- between N and P (they both live in the same register), only the bitmap
559 -- changes, so we could share the apply/save code between lots of cases.
585 genStackFns regstatus args
586 = genStackApply regstatus args
587 $$ genStackSave regstatus args
590 genStackApplyArray types =
592 text "section \"rodata\" {",
593 text "stg_ap_stack_entries:",
594 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
595 vcat (map arr_ent types),
599 arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
601 genStackSaveArray types =
603 text "section \"rodata\" {",
604 text "stg_stack_save_entries:",
605 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
606 vcat (map arr_ent types),
610 arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
612 genBitmapArray :: [[ArgRep]] -> Doc
613 genBitmapArray types =
615 text "section \"rodata\" {",
616 text "stg_arg_bitmaps:",
617 text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
618 vcat (map gen_bitmap types),
622 gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
624 (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
625 .|. sum (map argSize ty)