--- /dev/null
+{-# OPTIONS -cpp #-}
+module Main(main) where
+
+#include "config.h"
+#include "MachRegs.h"
+
+#if __GLASGOW_HASKELL__ >= 504
+import Text.PrettyPrint
+import Data.Word
+import Data.Bits
+import Data.List ( intersperse )
+import Data.Char ( toUpper )
+#else
+import Bits
+import Word
+import Pretty
+import List ( intersperse )
+import Char ( toUpper )
+#endif
+
+
+-- -----------------------------------------------------------------------------
+-- Argument kinds (rougly equivalent to PrimRep)
+
+data ArgRep
+ = N -- non-ptr
+ | P -- ptr
+ | V -- void
+ | F -- float
+ | D -- double
+ | L -- long (64-bit)
+
+-- size of a value in *words*
+argSize :: ArgRep -> Int
+argSize N = 1
+argSize P = 1
+argSize V = 0
+argSize F = 1
+argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
+argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
+
+showArg :: ArgRep -> Char
+showArg N = 'n'
+showArg P = 'p'
+showArg V = 'v'
+showArg F = 'f'
+showArg D = 'd'
+showArg L = 'l'
+
+-- is a value a pointer?
+isPtr :: ArgRep -> Bool
+isPtr P = True
+isPtr _ = False
+
+-- -----------------------------------------------------------------------------
+-- Registers
+
+type Reg = String
+
+availableRegs :: ([Reg],[Reg],[Reg],[Reg])
+availableRegs =
+ ( vanillaRegs MAX_REAL_VANILLA_REG,
+ floatRegs MAX_REAL_FLOAT_REG,
+ doubleRegs MAX_REAL_DOUBLE_REG,
+ longRegs MAX_REAL_LONG_REG
+ )
+
+vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
+vanillaRegs n = [ "R" ++ show m ++ ".w" | m <- [2..n] ] -- never use R1
+floatRegs n = [ "F" ++ show m | m <- [1..n] ]
+doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
+longRegs n = [ "L" ++ show m | m <- [1..n] ]
+
+-- -----------------------------------------------------------------------------
+-- Loading/saving register arguments to the stack
+
+loadRegArgs :: Int -> [ArgRep] -> (Doc,Int)
+loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
+ where
+ (reg_locs, sp') = assignRegs sp args
+
+-- a bit like assignRegs in CgRetConv.lhs
+assignRegs
+ :: Int -- Sp of first arg
+ -> [ArgRep] -- args
+ -> ([(Reg,Int)], Int) -- Sp and rest of args
+assignRegs sp args = assign sp args availableRegs []
+
+assign sp [] regs doc = (doc, sp)
+assign sp (V : args) regs doc = assign sp args regs doc
+assign sp (arg : args) regs doc
+ = case findAvailableReg arg regs of
+ Just (reg, regs') -> assign (sp + argSize arg) args regs'
+ ((reg, sp) : doc)
+ Nothing -> (doc, sp)
+
+findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
+ Just (vreg, (vregs,fregs,dregs,lregs))
+findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
+ Just (vreg, (vregs,fregs,dregs,lregs))
+findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
+ Just (freg, (vregs,fregs,dregs,lregs))
+findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
+ Just (dreg, (vregs,fregs,dregs,lregs))
+findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
+ Just (lreg, (vregs,fregs,dregs,lregs))
+findAvailableReg _ _ = Nothing
+
+assign_reg_to_stk reg@('F':_) sp
+ = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg@('D':_) sp
+ = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg@('L':_) sp
+ = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg sp
+ = text "Sp[" <> int sp <> text "] = " <> text reg <> semi
+
+assign_stk_to_reg reg@('F':_) sp
+ = text reg <> text " = " <> text "PK_FLT(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg@('D':_) sp
+ = text reg <> text " = " <> text "PK_DBL(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg@('L':_) sp
+ = text reg <> text " = " <> text "PK_Word64(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg sp
+ = text reg <> text " = Sp[" <> int sp <> text "];"
+
+
+-- make a ptr/non-ptr bitmap from a list of argument types
+mkBitmap :: [ArgRep] -> Word32
+mkBitmap args = foldr f 0 args
+ where f arg bm | isPtr arg = bm `shiftL` 1
+ | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
+ where size = argSize arg
+
+-- -----------------------------------------------------------------------------
+-- Generating the application functions
+
+mkApplyRetName args
+ = text "stg_ap_" <> text (map showArg args) <> text "_ret"
+
+mkApplyInfoName args
+ = text "stg_ap_" <> text (map showArg args) <> text "_info"
+
+genMkPAP macro jump is_pap args all_args_size fun_info_label
+ = smaller_arity_cases
+ $$ exact_arity_case
+ $$ larger_arity_case
+
+ where
+ n_args = length args
+
+-- The SMALLER ARITY cases:
+-- if (arity == 1) {
+-- Sp[0] = Sp[1];
+-- Sp[1] = (W_)&stg_ap_1_info;
+-- JMP_(GET_ENTRY(R1.cl));
+
+ smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
+
+ smaller_arity arity
+ = text "if (arity == " <> int arity <> text ") {" $$
+ let
+ (reg_doc, sp')
+ | is_pap = (empty, 1)
+ | otherwise = loadRegArgs 1 these_args
+ in
+ nest 4 (vcat [
+ reg_doc,
+ vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
+ text "Sp[" <> int these_args_size <> text "] = (W_)&" <>
+ mkApplyInfoName rest_args <> semi,
+ text "Sp += " <> int (sp' - 1) <> semi,
+ -- for a PAP, we have to arrange that the stack contains a
+ -- return address in the even that stg_PAP_entry fails its
+ -- heap check. See stg_PAP_entry in Apply.hc for details.
+ if is_pap
+ then text "Sp--; Sp[0] = (W_)&" <> mkApplyInfoName these_args <> semi
+ else empty,
+ text "JMP_" <> parens (text jump) <> semi
+ ]) $$
+ text "}"
+ where
+ (these_args, rest_args) = splitAt arity args
+ these_args_size = sum (map argSize these_args)
+
+ shuffle_down i =
+ text "Sp[" <> int (i-1) <> text "] = Sp["
+ <> int i <> text "];"
+
+-- The EXACT ARITY case
+--
+-- if (arity == 1) {
+-- Sp++;
+-- JMP_(GET_ENTRY(R1.cl));
+
+ exact_arity_case
+ = text "if (arity == " <> int n_args <> text ") {" $$
+ let
+ (reg_doc, sp')
+ | is_pap = (empty, 0)
+ | otherwise = loadRegArgs 1 args
+ in
+ nest 4 (vcat [
+ reg_doc,
+ text "Sp += " <> int sp' <> semi,
+ if is_pap
+ then text "Sp[0] = (W_)&" <> fun_info_label <> semi
+ else empty,
+ text "JMP_" <> parens (text jump) <> semi
+ ])
+
+-- The LARGER ARITY cases:
+--
+-- } else /* arity > 1 */ {
+-- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
+-- }
+
+ larger_arity_case =
+ text "} else {" $$
+ nest 4 (
+ text macro <> char '(' <> int n_args <> comma <>
+ int all_args_size <>
+ text ",(W_)&" <> fun_info_label <>
+ text ");"
+ ) $$
+ char '}'
+
+-- -----------------------------------------------------------------------------
+-- generate an apply function
+
+-- args is a list of 'p', 'n', 'f', 'd' or 'l'
+
+genApply args =
+ let
+ fun_ret_label = mkApplyRetName args
+ fun_info_label = mkApplyInfoName args
+ all_args_size = sum (map argSize args)
+ in
+ vcat [
+ text "INFO_TABLE_RET(" <> fun_info_label <> text "," <>
+ fun_ret_label <> text "," <>
+ text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <>
+ int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <>
+ text "0,0,0,RET_SMALL,,EF_,0,0);",
+ text "",
+ text "F_ " <> fun_ret_label <> text "( void )\n{",
+ nest 4 (vcat [
+ text "StgInfoTable *info;",
+ text "nat arity;",
+
+-- if fast == 1:
+-- print "static void *lbls[] ="
+-- print " { [FUN] &&fun_lbl,"
+-- print " [FUN_1_0] &&fun_lbl,"
+-- print " [FUN_0_1] &&fun_lbl,"
+-- print " [FUN_2_0] &&fun_lbl,"
+-- print " [FUN_1_1] &&fun_lbl,"
+-- print " [FUN_0_2] &&fun_lbl,"
+-- print " [FUN_STATIC] &&fun_lbl,"
+-- print " [PAP] &&pap_lbl,"
+-- print " [THUNK] &&thunk_lbl,"
+-- print " [THUNK_1_0] &&thunk_lbl,"
+-- print " [THUNK_0_1] &&thunk_lbl,"
+-- print " [THUNK_2_0] &&thunk_lbl,"
+-- print " [THUNK_1_1] &&thunk_lbl,"
+-- print " [THUNK_0_2] &&thunk_lbl,"
+-- print " [THUNK_STATIC] &&thunk_lbl,"
+-- print " [THUNK_SELECTOR] &&thunk_lbl,"
+-- print " [IND] &&ind_lbl,"
+-- print " [IND_OLDGEN] &&ind_lbl,"
+-- print " [IND_STATIC] &&ind_lbl,"
+-- print " [IND_PERM] &&ind_lbl,"
+-- print " [IND_OLDGEN_PERM] &&ind_lbl"
+-- print " };"
+
+ text "FB_",
+ text "",
+ text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <>
+ text "... \"); printClosure(R1.cl));",
+ text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
+ text ", CurrentTSO->stack + CurrentTSO->stack_size));",
+
+ text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
+
+ let do_assert [] _ = []
+ do_assert (arg:args) offset
+ | isPtr arg = this : rest
+ | otherwise = rest
+ where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp["
+ <> int offset <> text "]));"
+ rest = do_assert args (offset + argSize arg)
+ in
+ vcat (do_assert args 1),
+
+ text "again:",
+ text "info = get_itbl(R1.cl);",
+
+-- if fast == 1:
+-- print " goto *lbls[info->type];";
+-- else:
+ text "switch (info->type) {" $$
+ nest 4 (vcat [
+
+-- if fast == 1:
+-- print " fun_lbl:"
+-- else:
+ text "case FUN:",
+ text "case FUN_1_0:",
+ text "case FUN_0_1:",
+ text "case FUN_2_0:",
+ text "case FUN_1_1:",
+ text "case FUN_0_2:",
+ text "case FUN_STATIC:",
+ nest 4 (vcat [
+ text "arity = itbl_to_fun_itbl(info)->arity;",
+ text "ASSERT(arity > 0);",
+ genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)" False{-not PAP-}
+ args all_args_size fun_info_label
+ ]),
+
+-- if fast == 1:
+-- print " pap_lbl:"
+-- else:
+
+ text "case PAP:",
+ nest 4 (vcat [
+ text "arity = ((StgPAP *)R1.p)->arity;",
+ text "ASSERT(arity > 0);",
+ genMkPAP "NEW_PAP" "stg_PAP_entry" True{-is PAP-}
+ args all_args_size fun_info_label
+ ]),
+
+ text "",
+
+-- if fast == 1:
+-- print " thunk_lbl:"
+-- else:
+ text "case THUNK:",
+ text "case THUNK_1_0:",
+ text "case THUNK_0_1:",
+ text "case THUNK_2_0:",
+ text "case THUNK_1_1:",
+ text "case THUNK_0_2:",
+ text "case THUNK_STATIC:",
+ text "case THUNK_SELECTOR:",
+ nest 4 (vcat [
+ text "Sp[0] = (W_)&" <> fun_info_label <> text ";",
+ text "JMP_(GET_ENTRY(R1.cl));",
+ text ""
+ ]),
+
+-- if fast == 1:
+-- print " ind_lbl:"
+-- else:
+ text "case IND:",
+ text "case IND_OLDGEN:",
+ text "case IND_STATIC:",
+ text "case IND_PERM:",
+ text "case IND_OLDGEN_PERM:",
+ nest 4 (vcat [
+ text "R1.cl = ((StgInd *)R1.p)->indirectee;",
+ text "goto again;"
+ ]),
+ text "",
+
+-- if fast == 0:
+
+ text "default:",
+ nest 4 (
+ text "barf(\"" <> fun_ret_label <> text "\");"
+ ),
+ text "}"
+
+ ])
+ ]),
+ text "FE_",
+ text "}"
+ ]
+
+-- -----------------------------------------------------------------------------
+-- Making a stack apply
+
+-- These little functions are like slow entry points. They provide
+-- the layer between the PAP entry code and the function's fast entry
+-- point: namely they load arguments off the stack into registers (if
+-- available) and jump to the function's entry code.
+--
+-- On entry: R1 points to the function closure
+-- arguments are on the stack starting at Sp
+--
+-- Invariant: the list of arguments never contains void. Since we're only
+-- interested in loading arguments off the stack here, we can ignore
+-- void arguments.
+
+mkStackApplyEntryLabel:: [ArgRep] -> Doc
+mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
+
+genStackApply :: [ArgRep] -> Doc
+genStackApply args =
+ let fn_entry_label = mkStackApplyEntryLabel args in
+ vcat [
+ text "IFN_" <> parens fn_entry_label,
+ text "{",
+ nest 4 (text "FB_" $$ body $$ text "FE_"),
+ text "}"
+ ]
+ where
+ (assign_regs, sp') = loadRegArgs 0 args
+ body = vcat [assign_regs,
+ text "Sp += " <> int sp' <> semi,
+ text "JMP_(GET_ENTRY(R1.cl))"
+ ]
+
+-- -----------------------------------------------------------------------------
+-- Stack save entry points.
+--
+-- These code fragments are used to save registers on the stack at a heap
+-- check failure in the entry code for a function. We also have to save R1
+-- and the return address (stg_gen_ap_info) on the stack. See stg_fun_gc_gen
+-- in HeapStackCheck.hc for more details.
+
+mkStackSaveEntryLabel :: [ArgRep] -> Doc
+mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
+
+genStackSave :: [ArgRep] -> Doc
+genStackSave args =
+ let fn_entry_label= mkStackSaveEntryLabel args in
+ vcat [
+ text "IFN_" <> parens fn_entry_label,
+ text "{",
+ nest 4 (text "FB_" $$ body $$ text "FE_"),
+ text "}"
+ ]
+ where
+ body = vcat [text "Sp -= " <> int sp_offset <> semi,
+ vcat (map (uncurry assign_reg_to_stk) reg_locs),
+ text "Sp[2] = R1.w;",
+ text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi,
+ text "Sp[0] = (W_)&stg_gc_fun_info;",
+ text "JMP_(stg_gc_noregs);"
+ ]
+
+ std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
+ -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
+ (reg_locs, sp_offset) = assignRegs std_frame_size args
+
+-- -----------------------------------------------------------------------------
+-- The prologue...
+
+main = putStr (render the_code)
+ where the_code = vcat [
+ text "// DO NOT EDIT!",
+ text "// Automatically generated by GenApply.hs",
+ text "",
+ text "#include \"Stg.h\"",
+ text "#include \"Rts.h\"",
+ text "#include \"RtsFlags.h\"",
+ text "#include \"Storage.h\"",
+ text "#include \"RtsUtils.h\"",
+ text "#include \"Printer.h\"",
+ text "#include \"Sanity.h\"",
+ text "#include \"Apply.h\"",
+ text "",
+ text "#include <stdio.h>",
+
+ vcat (intersperse (text "") $ map genApply applyTypes),
+ vcat (intersperse (text "") $ map genStackFns stackApplyTypes),
+
+ genStackApplyArray stackApplyTypes,
+ genStackSaveArray stackApplyTypes,
+ genBitmapArray stackApplyTypes,
+
+ text "" -- add a newline at the end of the file
+ ]
+
+-- These have been shown to cover about 99% of cases in practice...
+applyTypes = [
+ [V],
+ [F],
+ [D],
+ [L],
+ [N],
+ [P],
+ [P,V],
+ [P,P],
+ [P,P,V],
+ [P,P,P],
+ [P,P,P,P],
+ [P,P,P,P,P],
+ [P,P,P,P,P,P],
+ [P,P,P,P,P,P,P]
+ ]
+
+-- No need for V args in the stack apply cases.
+-- ToDo: the stack apply and stack save code doesn't make a distinction
+-- between N and P (they both live in the same register), only the bitmap
+-- changes, so we could share the apply/save code between lots of cases.
+stackApplyTypes = [
+ [N],
+ [P],
+ [F],
+ [D],
+ [L],
+ [N,N],
+ [N,P],
+ [P,N],
+ [P,P],
+ [N,N,N],
+ [N,N,P],
+ [N,P,N],
+ [N,P,P],
+ [P,N,N],
+ [P,N,P],
+ [P,P,N],
+ [P,P,P],
+ [P,P,P,P],
+ [P,P,P,P,P],
+ [P,P,P,P,P,P],
+ [P,P,P,P,P,P,P],
+ [P,P,P,P,P,P,P,P]
+ ]
+
+genStackFns args = genStackApply args $$ genStackSave args
+
+
+genStackApplyArray types =
+ text "StgFun *stg_ap_stack_entries[] = {" $$
+ vcat (map arr_ent types) $$
+ text "};"
+ where
+ arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma
+
+genStackSaveArray types =
+ text "StgFun *stg_stack_save_entries[] = {" $$
+ vcat (map arr_ent types) $$
+ text "};"
+ where
+ arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma
+
+genBitmapArray :: [[ArgRep]] -> Doc
+genBitmapArray types =
+ vcat [
+ text "StgWord stg_arg_bitmaps[] = {",
+ vcat (map gen_bitmap types),
+ text "};"
+ ]
+ where
+ gen_bitmap ty = brackets (arg_const ty) <+>
+ text "MK_SMALL_BITMAP" <> parens (
+ int (sum (map argSize ty)) <> comma <>
+ text (show (mkBitmap ty))) <>
+ comma
+
+arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty))
+
projects / ghc-hetmet.git / blobdiff