X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fgenapply%2FGenApply.hs;h=eb29e2d4ef34c264446c1c865d4336963a162b3f;hp=cdde66fa78e579b6f1bbb1e98d0e952287b67ed2;hb=34cc75e1a62638f2833815746ebce0a9114dc26b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index cdde66f..eb29e2d 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -1,12 +1,19 @@ -{-# OPTIONS -cpp #-} +{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details module Main(main) where #include "../../includes/ghcconfig.h" #include "../../includes/MachRegs.h" #include "../../includes/Constants.h" +-- Needed for TAG_BITS +#include "../../includes/MachDeps.h" -#if __GLASGOW_HASKELL__ >= 504 import Text.PrettyPrint import Data.Word import Data.Bits @@ -14,14 +21,6 @@ import Data.List ( intersperse ) import System.Exit import System.Environment import System.IO -#else -import System -import IO -import Bits -import Word -import Pretty -import List ( intersperse ) -#endif -- ----------------------------------------------------------------------------- -- Argument kinds (rougly equivalent to PrimRep) @@ -174,10 +173,16 @@ mkApplyFastName args mkApplyInfoName args = mkApplyName args <> text "_info" +mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi + | 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 + is_fun_case = smaller_arity_cases $$ exact_arity_case $$ larger_arity_case @@ -202,7 +207,7 @@ genMkPAP regstatus macro jump ticker disamb smaller_arity arity = text "if (arity == " <> int arity <> text ") {" $$ nest 4 (vcat [ - text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();", + -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();", -- load up regs for the call, if necessary load_regs, @@ -223,7 +228,8 @@ genMkPAP regstatus macro jump ticker disamb if is_pap then text "R2 = " <> mkApplyInfoName this_call_args <> semi - else empty, + else empty, + if is_fun_case then mb_tag_node arity else empty, text "jump " <> text jump <> semi ]) $$ text "}" @@ -300,12 +306,13 @@ genMkPAP regstatus macro jump ticker disamb | otherwise = loadRegArgs regstatus stk_args_offset args in nest 4 (vcat [ - text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();", +-- 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_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 ]) @@ -326,8 +333,17 @@ genMkPAP regstatus macro jump ticker disamb empty in nest 4 (vcat [ - text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();", +-- 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 [ + text "if (arity < " <> int tAG_BITS_MAX <> text ") {", + text " R1 = R1 + arity" <> semi, + text "}" + ] + else empty + , text macro <> char '(' <> int n_args <> comma <> int all_args_size <> text "," <> fun_info_label <> @@ -341,10 +357,82 @@ genMkPAP regstatus macro jump ticker disamb = assignRegs regstatus stk_args_slow_offset args -- BUILD_PAP assumes args start at offset 1 +-- -------------------------------------- +-- Examine tag bits of function pointer and enter it +-- directly if needed. +-- TODO: remove the redundant case in the original code. +enterFastPath regstatus no_load_regs args_in_regs args + | Just tag <- tagForArity (length args) + = enterFastPathHelper tag regstatus no_load_regs args_in_regs args +enterFastPath _ _ _ _ = empty + +-- Copied from Constants.lhs & CgUtils.hs, i'd rather have this imported: +-- (arity,tag) +tAG_BITS = (TAG_BITS :: Int) +tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int) + +tagForArity :: Int -> Maybe Int +tagForArity i | i < tAG_BITS_MAX = Just i + | otherwise = Nothing + +enterFastPathHelper tag regstatus no_load_regs args_in_regs args = + vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {", + reg_doc, + text " Sp_adj(" <> int sp' <> text ");", + -- enter, but adjust offset with tag + 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. + stk_args_slow_offset = 1 + + stk_args_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 + +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 "}" + ] +tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;" + -- ----------------------------------------------------------------------------- -- generate an apply function -- args is a list of 'p', 'n', 'f', 'd' or 'l' +formalParam :: ArgRep -> Int -> Doc +formalParam V _ = empty +formalParam arg n = + formalParamType arg <> space <> + text "arg" <> int n <> text ", " +formalParamType arg = argRep arg + +argRep F = text "F_" +argRep D = text "D_" +argRep L = text "L_" +argRep P = text "gcptr" +argRep _ = text "W_" genApply regstatus args = let @@ -354,9 +442,8 @@ genApply regstatus args = in vcat [ text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <> - int all_args_size <> text "/*framsize*/," <> - int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <> - text "RET_SMALL)\n{", + text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <> + text ")\n{", nest 4 (vcat [ text "W_ info;", text "W_ arity;", @@ -386,6 +473,7 @@ genApply regstatus args = -- print " [IND_OLDGEN_PERM] &&ind_lbl" -- print " };" + tickForArity (length args), text "", text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <> text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));", @@ -396,7 +484,7 @@ genApply regstatus args = -- 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 ");", +-- text "TICK_SLOW_CALL(" <> int (length args) <> text ");", let do_assert [] _ = [] do_assert (arg:args) offset @@ -409,12 +497,18 @@ genApply regstatus args = vcat (do_assert args 1), text "again:", + + -- if pointer is tagged enter it fast! + enterFastPath regstatus False False args, + + -- Functions can be tagged, so we untag them! + text "R1 = UNTAG(R1);", text "info = %INFO_PTR(R1);", -- if fast == 1: -- print " goto *lbls[info->type];"; -- else: - text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(%STD_INFO(info))) {", + text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {", nest 4 (vcat [ -- if fast == 1: @@ -426,7 +520,7 @@ genApply regstatus args = 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 + args all_args_size fun_info_label {- tag stmt -}False ]), text "}", @@ -443,9 +537,9 @@ genApply regstatus args = nest 4 (vcat [ text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));", text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN" + 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 + args all_args_size fun_info_label {- tag stmt -}True ]), text "}", @@ -459,7 +553,7 @@ genApply regstatus args = 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 + args all_args_size fun_info_label {- tag stmt -}False ]), text "}", @@ -472,8 +566,6 @@ genApply regstatus args = text " AP_STACK,", text " CAF_BLACKHOLE,", text " BLACKHOLE,", - text " SE_BLACKHOLE,", - text " SE_CAF_BLACKHOLE,", text " THUNK,", text " THUNK_1_0,", text " THUNK_0_1,", @@ -483,7 +575,7 @@ genApply regstatus args = text " THUNK_STATIC,", text " THUNK_SELECTOR: {", nest 4 (vcat [ - text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");", +-- 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 @@ -504,6 +596,7 @@ genApply regstatus args = text " IND_OLDGEN_PERM: {", nest 4 (vcat [ text "R1 = StgInd_indirectee(R1);", + -- An indirection node might contain a tagged pointer text "goto again;" ]), text "}", @@ -513,7 +606,7 @@ genApply regstatus args = text "default: {", nest 4 ( - text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");" + text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;" ), text "}" @@ -539,8 +632,16 @@ genApplyFast regstatus args = nest 4 (vcat [ text "W_ info;", text "W_ arity;", + + tickForArity (length args), + + -- if pointer is tagged enter it fast! + enterFastPath regstatus False True args, + + -- Functions can be tagged, so we untag them! + text "R1 = UNTAG(R1);", text "info = %GET_STD_INFO(R1);", - text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(info)) {", + text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {", nest 4 (vcat [ text "case FUN,", text " FUN_1_0,", @@ -552,9 +653,9 @@ genApplyFast regstatus args = nest 4 (vcat [ text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));", text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN" + 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 + args all_args_size fun_info_label {- tag stmt -}True ]), char '}', @@ -605,7 +706,7 @@ genStackApply regstatus args = (assign_regs, sp') = loadRegArgs regstatus 0 args body = vcat [assign_regs, text "Sp_adj" <> parens (int sp') <> semi, - text "jump %GET_ENTRY(R1);" + text "jump %GET_ENTRY(UNTAG(R1));" ] -- ----------------------------------------------------------------------------- @@ -732,7 +833,7 @@ genStackFns regstatus args genStackApplyArray types = vcat [ - text "section \"rodata\" {", + text "section \"relrodata\" {", text "stg_ap_stack_entries:", text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO vcat (map arr_ent types), @@ -743,7 +844,7 @@ genStackApplyArray types = genStackSaveArray types = vcat [ - text "section \"rodata\" {", + text "section \"relrodata\" {", text "stg_stack_save_entries:", text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO vcat (map arr_ent types),