diff options
Diffstat (limited to 'utils/genapply')
| -rw-r--r-- | utils/genapply/GenApply.hs | 650 |
1 files changed, 325 insertions, 325 deletions
diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index b255b92d28..d00324f173 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -17,7 +17,7 @@ module Main(main) where import Text.PrettyPrint import Data.Word import Data.Bits -import Data.List ( intersperse ) +import Data.List ( intersperse ) import System.Exit import System.Environment import System.IO @@ -26,12 +26,12 @@ import System.IO -- Argument kinds (rougly equivalent to PrimRep) data ArgRep - = N -- non-ptr - | P -- ptr - | V -- void - | F -- float - | D -- double - | L -- long (64-bit) + = N -- non-ptr + | P -- ptr + | V -- void + | F -- float + | D -- double + | L -- long (64-bit) -- size of a value in *words* argSize :: ArgRep -> Int @@ -93,12 +93,12 @@ saveRegOffs = vcat . map (uncurry assign_reg_to_stk) -- a bit like assignRegs in CgRetConv.lhs assignRegs - :: RegStatus -- are we registerised? - -> Int -- Sp of first arg - -> [ArgRep] -- args - -> ([(Reg,Int)], -- regs and offsets to load - [ArgRep], -- left-over args - Int) -- Sp of left-over args + :: RegStatus -- are we registerised? + -> Int -- Sp of first arg + -> [ArgRep] -- args + -> ([(Reg,Int)], -- regs and offsets to load + [ArgRep], -- left-over args + Int) -- Sp of left-over args assignRegs regstatus sp args = assign sp args (availableRegs regstatus) [] assign sp [] regs doc = (doc, [], sp) @@ -106,7 +106,7 @@ 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) + ((reg, sp) : doc) Nothing -> (doc, (arg:args), sp) findAvailableReg N (vreg:vregs, fregs, dregs, lregs) = @@ -139,8 +139,8 @@ loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]" 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 + | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1) + where size = argSize arg -- ----------------------------------------------------------------------------- -- Generating the application functions @@ -174,113 +174,113 @@ mkApplyInfoName args = mkApplyName args <> text "_info" mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi - | otherwise = empty + | otherwise = empty mkTagStmt tag = text ("R1 = R1 + "++ show tag) genMkPAP regstatus macro jump ticker disamb - no_load_regs -- don't load argumnet regs before jumping - args_in_regs -- arguments are already in regs - is_pap args all_args_size fun_info_label + no_load_regs -- don't load argumnet regs before jumping + args_in_regs -- arguments are already in regs + is_pap args all_args_size fun_info_label is_fun_case = smaller_arity_cases $$ exact_arity_case $$ larger_arity_case - + where n_args = length args - -- offset of arguments on the stack at slow apply calls. + -- offset of arguments on the stack at slow apply calls. stk_args_slow_offset = 1 stk_args_offset - | args_in_regs = 0 - | otherwise = stk_args_slow_offset + | args_in_regs = 0 + | otherwise = stk_args_slow_offset -- The SMALLER ARITY cases: --- if (arity == 1) { --- Sp[0] = Sp[1]; --- Sp[1] = (W_)&stg_ap_1_info; --- JMP_(GET_ENTRY(R1.cl)); +-- 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 ") {" $$ nest 4 (vcat [ - -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();", - - -- load up regs for the call, if necessary - load_regs, - - -- If we have more args in registers than are required - -- for the call, then we must save some on the stack, - -- and set up the stack for the follow-up call. - -- If the extra arguments are on the stack, then we must - -- instead shuffle them down to make room for the info - -- table for the follow-on call. - if overflow_regs - then save_extra_regs - else shuffle_extra_args, - - -- 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 "R2 = " <> mkApplyInfoName this_call_args <> semi - - else empty, + -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();", + + -- load up regs for the call, if necessary + load_regs, + + -- If we have more args in registers than are required + -- for the call, then we must save some on the stack, + -- and set up the stack for the follow-up call. + -- If the extra arguments are on the stack, then we must + -- instead shuffle them down to make room for the info + -- table for the follow-on call. + if overflow_regs + then save_extra_regs + else shuffle_extra_args, + + -- 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 "R2 = " <> mkApplyInfoName this_call_args <> semi + + else empty, if is_fun_case then mb_tag_node arity else empty, if overflow_regs then text "jump_SAVE_CCCS" <> parens (text jump) <> semi else text "jump " <> text jump <> semi ]) $$ - text "}" - - where - -- offsets in case we need to save regs: - (reg_locs, _, _) - = assignRegs regstatus stk_args_offset args - - -- register assignment for *this function call* - (reg_locs', reg_call_leftovers, reg_call_sp_stk_args) - = assignRegs regstatus stk_args_offset (take arity args) - - load_regs - | no_load_regs || args_in_regs = empty - | otherwise = loadRegOffs reg_locs' - - (this_call_args, rest_args) = splitAt arity args - - -- the offset of the stack args from initial Sp - sp_stk_args - | args_in_regs = stk_args_offset - | no_load_regs = stk_args_offset - | otherwise = reg_call_sp_stk_args - - -- the stack args themselves - this_call_stack_args - | args_in_regs = reg_call_leftovers -- sp offsets are wrong - | no_load_regs = this_call_args - | otherwise = reg_call_leftovers - - stack_args_size = sum (map argSize this_call_stack_args) - - overflow_regs = args_in_regs && length reg_locs > length reg_locs' - - save_extra_regs - = -- we have extra arguments in registers to save - let - extra_reg_locs = drop (length reg_locs') (reverse reg_locs) - adj_reg_locs = [ (reg, off - adj + 1) | - (reg,off) <- extra_reg_locs ] - adj = case extra_reg_locs of - (reg, fst_off):_ -> fst_off - size = snd (last adj_reg_locs) - in - text "Sp_adj(" <> int (-size - 1) <> text ");" $$ - saveRegOffs adj_reg_locs $$ - loadSpWordOff "W_" 0 <> text " = " <> - mkApplyInfoName rest_args <> semi + text "}" + + where + -- offsets in case we need to save regs: + (reg_locs, _, _) + = assignRegs regstatus stk_args_offset args + + -- register assignment for *this function call* + (reg_locs', reg_call_leftovers, reg_call_sp_stk_args) + = assignRegs regstatus stk_args_offset (take arity args) + + load_regs + | no_load_regs || args_in_regs = empty + | otherwise = loadRegOffs reg_locs' + + (this_call_args, rest_args) = splitAt arity args + + -- the offset of the stack args from initial Sp + sp_stk_args + | args_in_regs = stk_args_offset + | no_load_regs = stk_args_offset + | otherwise = reg_call_sp_stk_args + + -- the stack args themselves + this_call_stack_args + | args_in_regs = reg_call_leftovers -- sp offsets are wrong + | no_load_regs = this_call_args + | otherwise = reg_call_leftovers + + stack_args_size = sum (map argSize this_call_stack_args) + + overflow_regs = args_in_regs && length reg_locs > length reg_locs' + + save_extra_regs + = -- we have extra arguments in registers to save + let + extra_reg_locs = drop (length reg_locs') (reverse reg_locs) + adj_reg_locs = [ (reg, off - adj + 1) | + (reg,off) <- extra_reg_locs ] + adj = case extra_reg_locs of + (reg, fst_off):_ -> fst_off + size = snd (last adj_reg_locs) + in + text "Sp_adj(" <> int (-size - 1) <> text ");" $$ + saveRegOffs adj_reg_locs $$ + loadSpWordOff "W_" 0 <> text " = " <> + mkApplyInfoName rest_args <> semi shuffle_extra_args = vcat [text "#ifdef PROFILING", @@ -310,52 +310,52 @@ genMkPAP regstatus macro jump ticker disamb shuffle_down j i = loadSpWordOff "W_" (i-j) <> text " = " <> - loadSpWordOff "W_" i <> semi + loadSpWordOff "W_" i <> semi -- The EXACT ARITY case -- --- if (arity == 1) { --- Sp++; --- JMP_(GET_ENTRY(R1.cl)); +-- if (arity == 1) { +-- Sp++; +-- JMP_(GET_ENTRY(R1.cl)); exact_arity_case - = text "if (arity == " <> int n_args <> text ") {" $$ - let - (reg_doc, sp') - | no_load_regs || args_in_regs = (empty, stk_args_offset) - | otherwise = loadRegArgs regstatus stk_args_offset args - in - nest 4 (vcat [ --- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();", - reg_doc, - text "Sp_adj(" <> int sp' <> text ");", + = text "if (arity == " <> int n_args <> text ") {" $$ + let + (reg_doc, sp') + | no_load_regs || args_in_regs = (empty, stk_args_offset) + | otherwise = loadRegArgs regstatus stk_args_offset args + in + nest 4 (vcat [ +-- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();", + reg_doc, + text "Sp_adj(" <> int sp' <> text ");", if is_pap then text "R2 = " <> fun_info_label <> semi else empty, if is_fun_case then mb_tag_node n_args else empty, - text "jump " <> text jump <> semi - ]) + text "jump " <> text jump <> semi + ]) -- The LARGER ARITY cases: -- --- } else /* arity > 1 */ { --- BUILD_PAP(1,0,(W_)&stg_ap_v_info); --- } +-- } else /* arity > 1 */ { +-- BUILD_PAP(1,0,(W_)&stg_ap_v_info); +-- } larger_arity_case = - text "} else {" $$ - let - save_regs - | args_in_regs = - text "Sp_adj(" <> int (-sp_offset) <> text ");" $$ - saveRegOffs reg_locs - | otherwise = - empty - in - nest 4 (vcat [ --- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();", - save_regs, + text "} else {" $$ + let + save_regs + | args_in_regs = + text "Sp_adj(" <> int (-sp_offset) <> text ");" $$ + saveRegOffs reg_locs + | otherwise = + empty + in + nest 4 (vcat [ +-- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();", + save_regs, -- Before building the PAP, tag the function closure pointer if is_fun_case then vcat [ @@ -365,18 +365,18 @@ genMkPAP regstatus macro jump ticker disamb ] else empty , - text macro <> char '(' <> int n_args <> comma <> - int all_args_size <> - text "," <> fun_info_label <> - text "," <> text disamb <> - text ");" - ]) $$ - char '}' - where - -- offsets in case we need to save regs: - (reg_locs, leftovers, sp_offset) - = assignRegs regstatus stk_args_slow_offset args - -- BUILD_PAP assumes args start at offset 1 + text macro <> char '(' <> int n_args <> comma <> + int all_args_size <> + text "," <> fun_info_label <> + text "," <> text disamb <> + text ");" + ]) $$ + char '}' + where + -- offsets in case we need to save regs: + (reg_locs, leftovers, sp_offset) + = assignRegs regstatus stk_args_slow_offset args + -- BUILD_PAP assumes args start at offset 1 -- Note [jump_SAVE_CCCS] @@ -413,44 +413,44 @@ tagForArity i | i < tAG_BITS_MAX = Just i enterFastPathHelper tag regstatus no_load_regs args_in_regs args = vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {", - reg_doc, + reg_doc, text " Sp_adj(" <> int sp' <> text ");", -- enter, but adjust offset with tag - text " jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ");", + text " jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ");", text "}" ] -- I don't totally understand this code, I copied it from -- exact_arity_case -- TODO: refactor where - -- offset of arguments on the stack at slow apply calls. + -- offset of arguments on the stack at slow apply calls. stk_args_slow_offset = 1 stk_args_offset - | args_in_regs = 0 - | otherwise = stk_args_slow_offset + | args_in_regs = 0 + | otherwise = stk_args_slow_offset (reg_doc, sp') - | no_load_regs || args_in_regs = (empty, stk_args_offset) - | otherwise = loadRegArgs regstatus stk_args_offset args + | no_load_regs || args_in_regs = (empty, stk_args_offset) + | otherwise = loadRegArgs regstatus stk_args_offset args tickForArity arity | True = empty | Just tag <- tagForArity arity = vcat [ - text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;", - text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;", - text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {", - text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;", - text " if (GETTAG(R1)==" <> int tag <> text ") {", - text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;", - text " } else {", - -- force a halt when not tagged! --- text " W_[0]=0;", - text " }", - text "}" - ] + text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;", + text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;", + text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {", + text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;", + text " if (GETTAG(R1)==" <> int tag <> text ") {", + text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;", + text " } else {", + -- force a halt when not tagged! +-- text " W_[0]=0;", + text " }", + text "}" + ] tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;" -- ----------------------------------------------------------------------------- @@ -488,45 +488,45 @@ genApply regstatus args = -- 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_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_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] &&ind_lbl," -- print " [IND_STATIC] &&ind_lbl," --- print " [IND_PERM] &&ind_lbl," +-- print " [IND_PERM] &&ind_lbl," -- print " };" tickForArity (length args), text "", text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <> - text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));", + text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));", text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size) - <> text ")\"ptr\"));", + <> text ")\"ptr\"));", -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <> --- text ", CurrentTSO->stack + CurrentTSO->stack_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) + 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), @@ -543,20 +543,20 @@ genApply regstatus args = -- print " goto *lbls[info->type];"; -- else: text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {", - nest 4 (vcat [ + nest 4 (vcat [ -- if fast == 1: -- print " bco_lbl:" -- else: - text "case BCO: {", - nest 4 (vcat [ - text "arity = TO_W_(StgBCO_arity(R1));", - text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO" - True{-stack apply-} False{-args on stack-} False{-not a PAP-} - args all_args_size fun_info_label {- tag stmt -}False - ]), - text "}", + text "case BCO: {", + nest 4 (vcat [ + text "arity = TO_W_(StgBCO_arity(R1));", + text "ASSERT(arity > 0);", + genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO" + True{-stack apply-} False{-args on stack-} False{-not a PAP-} + args all_args_size fun_info_label {- tag stmt -}False + ]), + text "}", -- if fast == 1: -- print " fun_lbl:" @@ -568,38 +568,38 @@ genApply regstatus args = text " FUN_1_1,", text " FUN_0_2,", text " FUN_STATIC: {", - nest 4 (vcat [ - text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));", - text "ASSERT(arity > 0);", + nest 4 (vcat [ + text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));", + text "ASSERT(arity > 0);", genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN" - False{-reg apply-} False{-args on stack-} False{-not a PAP-} - args all_args_size fun_info_label {- tag stmt -}True - ]), - text "}", + False{-reg apply-} False{-args on stack-} False{-not a PAP-} + args all_args_size fun_info_label {- tag stmt -}True + ]), + text "}", -- if fast == 1: -- print " pap_lbl:" -- else: - text "case PAP: {", - nest 4 (vcat [ - text "arity = TO_W_(StgPAP_arity(R1));", - text "ASSERT(arity > 0);", - genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP" - True{-stack apply-} False{-args on stack-} True{-is a PAP-} - args all_args_size fun_info_label {- tag stmt -}False - ]), - text "}", + text "case PAP: {", + nest 4 (vcat [ + text "arity = TO_W_(StgPAP_arity(R1));", + text "ASSERT(arity > 0);", + genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP" + True{-stack apply-} False{-args on stack-} True{-is a PAP-} + args all_args_size fun_info_label {- tag stmt -}False + ]), + text "}", - text "", + text "", -- if fast == 1: -- print " thunk_lbl:" -- else: - text "case AP,", - text " AP_STACK,", - text " BLACKHOLE,", - text " WHITEHOLE,", + text "case AP,", + text " AP_STACK,", + text " BLACKHOLE,", + text " WHITEHOLE,", text " THUNK,", text " THUNK_1_0,", text " THUNK_0_1,", @@ -608,18 +608,18 @@ genApply regstatus args = text " THUNK_0_2,", text " THUNK_STATIC,", text " THUNK_SELECTOR: {", - nest 4 (vcat [ + nest 4 (vcat [ -- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");", - text "Sp(0) = " <> fun_info_label <> text ";", - -- CAREFUL! in SMP mode, the info table may already have been - -- overwritten by an indirection, so we must enter the original - -- info pointer we read, don't read it again, because it might - -- not be enterable any more. + text "Sp(0) = " <> fun_info_label <> text ";", + -- CAREFUL! in SMP mode, the info table may already have been + -- overwritten by an indirection, so we must enter the original + -- info pointer we read, don't read it again, because it might + -- not be enterable any more. text "jump_SAVE_CCCS(%ENTRY_CODE(info));", -- see Note [jump_SAVE_CCCS] text "" - ]), - text "}", + ]), + text "}", -- if fast == 1: -- print " ind_lbl:" @@ -627,13 +627,13 @@ genApply regstatus args = text "case IND,", text " IND_STATIC,", text " IND_PERM: {", - nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + nest 4 (vcat [ + text "R1 = StgInd_indirectee(R1);", -- An indirection node might contain a tagged pointer - text "goto again;" - ]), - text "}", - text "", + text "goto again;" + ]), + text "}", + text "", -- if fast == 0: @@ -642,8 +642,8 @@ genApply regstatus args = text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;" ), text "}" - - ]), + + ]), text "}" ]), text "}" @@ -675,7 +675,7 @@ genApplyFast regstatus args = text "R1 = UNTAG(R1);", text "info = %GET_STD_INFO(R1);", text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {", - nest 4 (vcat [ + nest 4 (vcat [ text "case FUN,", text " FUN_1_0,", text " FUN_0_1,", @@ -683,29 +683,29 @@ genApplyFast regstatus args = text " FUN_1_1,", text " FUN_0_2,", text " FUN_STATIC: {", - nest 4 (vcat [ - text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));", - text "ASSERT(arity > 0);", + nest 4 (vcat [ + text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));", + text "ASSERT(arity > 0);", genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN" - False{-reg apply-} True{-args in regs-} False{-not a PAP-} - args all_args_size fun_info_label {- tag stmt -}True - ]), - char '}', - - text "default: {", - let - (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args - -- leave a one-word space on the top of the stack when - -- calling the slow version - in - nest 4 (vcat [ - text "Sp_adj" <> parens (int (-sp_offset)) <> semi, - saveRegOffs reg_locs, - text "jump" <+> fun_ret_label <> semi - ]), - char '}' - ]), - char '}' + False{-reg apply-} True{-args in regs-} False{-not a PAP-} + args all_args_size fun_info_label {- tag stmt -}True + ]), + char '}', + + text "default: {", + let + (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args + -- leave a one-word space on the top of the stack when + -- calling the slow version + in + nest 4 (vcat [ + text "Sp_adj" <> parens (int (-sp_offset)) <> semi, + saveRegOffs reg_locs, + text "jump" <+> fun_ret_label <> semi + ]), + char '}' + ]), + char '}' ]), char '}' ] @@ -719,7 +719,7 @@ genApplyFast regstatus args = -- 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 +-- 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 @@ -738,9 +738,9 @@ genStackApply regstatus args = where (assign_regs, sp') = loadRegArgs regstatus 0 args body = vcat [assign_regs, - text "Sp_adj" <> parens (int sp') <> semi, - text "jump %GET_ENTRY(UNTAG(R1));" - ] + text "Sp_adj" <> parens (int sp') <> semi, + text "jump %GET_ENTRY(UNTAG(R1));" + ] -- ----------------------------------------------------------------------------- -- Stack save entry points. @@ -762,15 +762,15 @@ genStackSave regstatus args = ] where body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi, - saveRegOffs reg_locs, - text "Sp(2) = R1;", - text "Sp(1) =" <+> int stk_args <> semi, - text "Sp(0) = stg_gc_fun_info;", - text "jump stg_gc_noregs;" - ] + saveRegOffs reg_locs, + text "Sp(2) = R1;", + text "Sp(1) =" <+> int stk_args <> semi, + text "Sp(0) = stg_gc_fun_info;", + text "jump 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. + -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc. (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args -- number of words of arguments on the stack. @@ -782,51 +782,51 @@ genStackSave regstatus args = main = do args <- getArgs regstatus <- case args of - [] -> return Registerised - ["-u"] -> return Unregisterised - _other -> do hPutStrLn stderr "syntax: genapply [-u]" - exitWith (ExitFailure 1) + [] -> return Registerised + ["-u"] -> return Unregisterised + _other -> do hPutStrLn stderr "syntax: genapply [-u]" + exitWith (ExitFailure 1) let the_code = vcat [ - text "// DO NOT EDIT!", - text "// Automatically generated by GenApply.hs", - text "", - text "#include \"Cmm.h\"", - text "#include \"AutoApply.h\"", - text "", - - vcat (intersperse (text "") $ - map (genApply regstatus) applyTypes), - vcat (intersperse (text "") $ - map (genStackFns regstatus) stackApplyTypes), - - vcat (intersperse (text "") $ - map (genApplyFast regstatus) applyTypes), - - genStackApplyArray stackApplyTypes, - genStackSaveArray stackApplyTypes, - genBitmapArray stackApplyTypes, - - text "" -- add a newline at the end of the file - ] + text "// DO NOT EDIT!", + text "// Automatically generated by GenApply.hs", + text "", + text "#include \"Cmm.h\"", + text "#include \"AutoApply.h\"", + text "", + + vcat (intersperse (text "") $ + map (genApply regstatus) applyTypes), + vcat (intersperse (text "") $ + map (genStackFns regstatus) stackApplyTypes), + + vcat (intersperse (text "") $ + map (genApplyFast regstatus) applyTypes), + + genStackApplyArray stackApplyTypes, + genStackSaveArray stackApplyTypes, + genBitmapArray stackApplyTypes, + + text "" -- add a newline at the end of the file + ] -- in putStr (render the_code) -- 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,V], - [P,P,P,P], - [P,P,P,P,P], - [P,P,P,P,P,P] + [V], + [F], + [D], + [L], + [N], + [P], + [P,V], + [P,P], + [P,P,V], + [P,P,P], + [P,P,P,V], + [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. @@ -834,29 +834,29 @@ applyTypes = [ -- 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] + [], + [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 regstatus args @@ -897,7 +897,7 @@ genBitmapArray types = ] where gen_bitmap ty = text "W_" <+> int bitmap_val <> semi - where bitmap_val = - (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT) - .|. sum (map argSize ty) + where bitmap_val = + (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT) + .|. sum (map argSize ty) |