-{-# 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
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)
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
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,
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 "}"
| 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
])
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 <>
= 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
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;",
-- 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\"));",
-- 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
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:
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 "}",
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 "}",
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 "}",
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,",
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
text " IND_OLDGEN_PERM: {",
nest 4 (vcat [
text "R1 = StgInd_indirectee(R1);",
+ -- An indirection node might contain a tagged pointer
text "goto again;"
]),
text "}",
text "default: {",
nest 4 (
- text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");"
+ text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;"
),
text "}"
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,",
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 '}',
(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));"
]
-- -----------------------------------------------------------------------------
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),
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),
projects / ghc-hetmet.git / blobdiff