{-# OPTIONS -cpp #-}
module Main(main) where
-#include "config.h"
-#include "MachRegs.h"
+#include "../../includes/config.h"
+#include "../../includes/MachRegs.h"
#if __GLASGOW_HASKELL__ >= 504
import Text.PrettyPrint
mkApplyInfoName args
= text "stg_ap_" <> text (map showArg args) <> text "_info"
-genMkPAP macro jump is_pap args all_args_size fun_info_label
+genMkPAP macro jump stack_apply is_pap args all_args_size fun_info_label
= smaller_arity_cases
$$ exact_arity_case
$$ larger_arity_case
= text "if (arity == " <> int arity <> text ") {" $$
let
(reg_doc, sp')
- | is_pap = (empty, 1)
- | otherwise = loadRegArgs 1 these_args
+ | stack_apply = (empty, 1)
+ | otherwise = loadRegArgs 1 these_args
in
nest 4 (vcat [
reg_doc,
-- 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
+ then text "R2.w = (W_)&" <> mkApplyInfoName these_args <> semi
else empty,
text "JMP_" <> parens (text jump) <> semi
]) $$
= text "if (arity == " <> int n_args <> text ") {" $$
let
(reg_doc, sp')
- | is_pap = (empty, 0)
- | otherwise = loadRegArgs 1 args
+ | stack_apply = (empty, 1)
+ | 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
+ then text "R2.w = (W_)&" <> fun_info_label <> semi
else empty,
text "JMP_" <> parens (text jump) <> semi
])
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 "IF_DEBUG(sanity,checkStackFrame(Sp+" <> int (1 + all_args_size)
+ <> text "));",
+
+-- 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 ");",
nest 4 (vcat [
-- if fast == 1:
+-- print " bco_lbl:"
+-- else:
+ text "case BCO:",
+ nest 4 (vcat [
+ text "arity = ((StgBCO *)R1.p)->arity;",
+ text "ASSERT(arity > 0);",
+ genMkPAP "BUILD_PAP" "stg_BCO_entry"
+ True{-stack apply-} False{-not a PAP-}
+ args all_args_size fun_info_label
+ ]),
+
+-- if fast == 1:
-- print " fun_lbl:"
-- else:
text "case FUN:",
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-}
+ genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)"
+ False{-reg apply-} False{-not a PAP-}
args all_args_size fun_info_label
]),
nest 4 (vcat [
text "arity = ((StgPAP *)R1.p)->arity;",
text "ASSERT(arity > 0);",
- genMkPAP "NEW_PAP" "stg_PAP_entry" True{-is PAP-}
+ genMkPAP "NEW_PAP" "stg_PAP_entry"
+ True{-stack apply-} True{-is a PAP-}
args all_args_size fun_info_label
]),
-- if fast == 1:
-- print " thunk_lbl:"
-- else:
+ text "case AP:",
+ text "case AP_STACK:",
+ text "case CAF_BLACKHOLE:",
+ text "case BLACKHOLE:",
+ text "case BLACKHOLE_BQ:",
+ text "case SE_BLACKHOLE:",
+ text "case SE_CAF_BLACKHOLE:",
text "case THUNK:",
text "case THUNK_1_0:",
text "case THUNK_0_1:",
genStackApply args =
let fn_entry_label = mkStackApplyEntryLabel args in
vcat [
- text "IFN_" <> parens fn_entry_label,
+ text "IF_" <> parens fn_entry_label,
text "{",
nest 4 (text "FB_" $$ body $$ text "FE_"),
text "}"
(assign_regs, sp') = loadRegArgs 0 args
body = vcat [assign_regs,
text "Sp += " <> int sp' <> semi,
- text "JMP_(GET_ENTRY(R1.cl))"
+ text "JMP_(GET_ENTRY(R1.cl));"
]
-- -----------------------------------------------------------------------------
--
-- 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
+-- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
-- in HeapStackCheck.hc for more details.
mkStackSaveEntryLabel :: [ArgRep] -> Doc
genStackSave args =
let fn_entry_label= mkStackSaveEntryLabel args in
vcat [
- text "IFN_" <> parens fn_entry_label,
+ text "IF_" <> parens fn_entry_label,
text "{",
nest 4 (text "FB_" $$ body $$ text "FE_"),
text "}"