mirror of
https://github.com/open-goal/jak-project
synced 2026-07-07 22:22:21 -04:00
fix printing and add gstate (#330)
This commit is contained in:
@@ -159,6 +159,16 @@ struct PrettyPrinterNode {
|
||||
nullptr; // pointer to open paren if in parens. open paren points to close and vice versa
|
||||
explicit PrettyPrinterNode(FormToken* _tok) { tok = _tok; }
|
||||
PrettyPrinterNode() = default;
|
||||
|
||||
std::string debug_print() const {
|
||||
std::string result;
|
||||
if (tok) {
|
||||
result += fmt::format("tok: \"{}\"\n", tok->toString());
|
||||
}
|
||||
result += fmt::format("line: {}\nlineIn: {}\noffset: {}\nspecial: {}\nsep?: {}\n", line,
|
||||
lineIndent, offset, specialIndentDelta, is_line_separator);
|
||||
return result;
|
||||
}
|
||||
};
|
||||
|
||||
/*!
|
||||
@@ -343,14 +353,64 @@ PrettyPrinterNode* getNextLine(PrettyPrinterNode* start) {
|
||||
PrettyPrinterNode* getNextListOnLine(PrettyPrinterNode* start) {
|
||||
int line = start->line;
|
||||
assert(!start->is_line_separator);
|
||||
if (!start->next || start->next->is_line_separator)
|
||||
if (!start->next || start->next->is_line_separator) {
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
start = start->next;
|
||||
while (!start->is_line_separator && start->line == line) {
|
||||
if (start->tok->kind == FormToken::TokenKind::OPEN_PAREN)
|
||||
if (start->tok->kind == FormToken::TokenKind::OPEN_PAREN) {
|
||||
return start;
|
||||
if (!start->next)
|
||||
}
|
||||
if (!start->next) {
|
||||
return nullptr;
|
||||
}
|
||||
start = start->next;
|
||||
}
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
PrettyPrinterNode* getNextOfKindOrStringOnLine(PrettyPrinterNode* start,
|
||||
FormToken::TokenKind kind) {
|
||||
int line = start->line;
|
||||
assert(!start->is_line_separator);
|
||||
if (!start->next || start->next->is_line_separator) {
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
start = start->next;
|
||||
while (!start->is_line_separator && start->line == line) {
|
||||
if (start->tok->kind == kind || start->tok->kind == FormToken::TokenKind::OPEN_PAREN) {
|
||||
return start;
|
||||
}
|
||||
if (!start->next) {
|
||||
return nullptr;
|
||||
}
|
||||
start = start->next;
|
||||
}
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
PrettyPrinterNode* getNextListOrEmptyListOnLine(PrettyPrinterNode* start) {
|
||||
int line = start->line;
|
||||
assert(!start->is_line_separator);
|
||||
if (!start->next || start->next->is_line_separator) {
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
start = start->next;
|
||||
while (!start->is_line_separator && start->line == line) {
|
||||
if (start->tok->kind == FormToken::TokenKind::OPEN_PAREN) {
|
||||
return start;
|
||||
}
|
||||
|
||||
if (start->tok->kind == FormToken::TokenKind::EMPTY_PAIR) {
|
||||
return start;
|
||||
}
|
||||
|
||||
if (!start->next) {
|
||||
return nullptr;
|
||||
}
|
||||
start = start->next;
|
||||
}
|
||||
return nullptr;
|
||||
@@ -515,10 +575,14 @@ void insertSpecialBreaks(NodePool& pool, PrettyPrinterNode* node) {
|
||||
|
||||
if (name == "defun" || name == "defmethod" || name == "defun-debug" || name == "let" ||
|
||||
name == "let*") {
|
||||
auto* first_list = getNextListOnLine(node);
|
||||
auto* first_list = getNextListOrEmptyListOnLine(node);
|
||||
if (first_list) {
|
||||
insertNewlineAfter(pool, first_list->paren, 0);
|
||||
breakList(pool, node->paren, first_list);
|
||||
if (first_list->tok->kind == FormToken::TokenKind::EMPTY_PAIR) {
|
||||
insertNewlineAfter(pool, first_list, 0);
|
||||
} else {
|
||||
insertNewlineAfter(pool, first_list->paren, 0);
|
||||
breakList(pool, node->paren, first_list);
|
||||
}
|
||||
}
|
||||
|
||||
if ((name == "let" || name == "let*") && first_list) {
|
||||
@@ -560,10 +624,17 @@ void insertSpecialBreaks(NodePool& pool, PrettyPrinterNode* node) {
|
||||
}
|
||||
|
||||
if (control_flow_start_forms.find(name) != control_flow_start_forms.end()) {
|
||||
auto* parent_type_dec = getNextListOnLine(node);
|
||||
auto* parent_type_dec = getNextOfKindOrStringOnLine(node, FormToken::TokenKind::STRING);
|
||||
|
||||
if (parent_type_dec) {
|
||||
insertNewlineAfter(pool, parent_type_dec->paren, 0);
|
||||
breakList(pool, node->paren, parent_type_dec);
|
||||
if (parent_type_dec->tok->kind == FormToken::TokenKind::OPEN_PAREN) {
|
||||
insertNewlineAfter(pool, parent_type_dec->paren, 0);
|
||||
breakList(pool, node->paren, parent_type_dec);
|
||||
} else {
|
||||
insertNewlineAfter(pool, parent_type_dec, 0);
|
||||
breakList(pool, node->paren, parent_type_dec);
|
||||
}
|
||||
|
||||
auto open_paren = node->prev;
|
||||
if (open_paren && open_paren->tok->kind == FormToken::TokenKind::OPEN_PAREN) {
|
||||
if (open_paren->prev && !open_paren->prev->is_line_separator) {
|
||||
|
||||
@@ -42,7 +42,8 @@ InstructionParser::InstructionParser() {
|
||||
InstructionKind::BLTZ, InstructionKind::BGEZ, InstructionKind::BLEZ,
|
||||
InstructionKind::BGTZ, InstructionKind::BLTZL, InstructionKind::BGTZL,
|
||||
InstructionKind::BGEZL, InstructionKind::MTC1, InstructionKind::MFC1,
|
||||
InstructionKind::MFLO, InstructionKind::MFHI}) {
|
||||
InstructionKind::MFLO, InstructionKind::MFHI, InstructionKind::MTLO1,
|
||||
InstructionKind::MFLO1}) {
|
||||
auto& info = gOpcodeInfo[int(i)];
|
||||
if (info.defined) {
|
||||
m_opcode_name_lookup[info.name] = int(i);
|
||||
|
||||
@@ -290,12 +290,47 @@ void Function::analyze_prologue(const LinkedObjectFile& file) {
|
||||
// it's fine to have the entire first basic block be the prologue - you could loop back to the
|
||||
// first instruction past the prologue.
|
||||
assert(basic_blocks.at(0).end_word >= prologue_end);
|
||||
basic_blocks.at(0).start_word = prologue_end;
|
||||
resize_first_block(prologue_end, file);
|
||||
prologue.decoded = true;
|
||||
|
||||
check_epilogue(file);
|
||||
}
|
||||
|
||||
void Function::resize_first_block(int new_start, const LinkedObjectFile&) {
|
||||
basic_blocks.at(0).start_word = new_start;
|
||||
|
||||
if (basic_blocks.size() >= 2 && basic_blocks.at(1).start_word == new_start) {
|
||||
lg::warn("Function {} loops back to the first instruction. This is rare/less tested.",
|
||||
guessed_name.to_string());
|
||||
// block 1 is now zero size, so we should eliminate it
|
||||
auto& block0 = basic_blocks.at(0);
|
||||
auto& block1 = basic_blocks.at(1);
|
||||
block0.succ_ft = block1.succ_ft;
|
||||
block0.succ_branch = block1.succ_branch;
|
||||
block0.end_word = block1.end_word;
|
||||
// it's only safe to this immediately after the basic block pass.
|
||||
// now copy back:
|
||||
for (size_t i = 1; i < basic_blocks.size() - 1; i++) {
|
||||
basic_blocks[i] = basic_blocks[i + 1];
|
||||
}
|
||||
|
||||
for (auto& block : basic_blocks) {
|
||||
if (block.succ_branch > 0) {
|
||||
block.succ_branch--;
|
||||
}
|
||||
if (block.succ_ft > 0) {
|
||||
block.succ_ft--;
|
||||
}
|
||||
for (auto& p : block.pred) {
|
||||
if (p > 0) {
|
||||
p--;
|
||||
}
|
||||
}
|
||||
}
|
||||
basic_blocks.pop_back();
|
||||
}
|
||||
}
|
||||
|
||||
/*!
|
||||
* Print info about the prologue and stack.
|
||||
*/
|
||||
|
||||
@@ -174,6 +174,7 @@ class Function {
|
||||
|
||||
private:
|
||||
void check_epilogue(const LinkedObjectFile& file);
|
||||
void resize_first_block(int new_start, const LinkedObjectFile& file);
|
||||
std::unordered_map<int, int> instruction_to_basic_op;
|
||||
std::unordered_map<int, int> basic_op_to_instruction;
|
||||
};
|
||||
|
||||
@@ -298,7 +298,8 @@ SetVarElement::SetVarElement(const RegisterAccess& var,
|
||||
goos::Object SetVarElement::to_form_internal(const Env& env) const {
|
||||
assert(active());
|
||||
auto reg_kind = m_dst.reg().get_kind();
|
||||
if ((reg_kind == Reg::FPR || reg_kind == Reg::GPR) && env.has_type_analysis()) {
|
||||
if ((reg_kind == Reg::FPR || reg_kind == Reg::GPR) && env.has_type_analysis() &&
|
||||
env.has_local_vars()) {
|
||||
auto expected_type = env.get_variable_type(m_dst, true);
|
||||
if (!env.dts->ts.tc(expected_type, m_src_type)) {
|
||||
return pretty_print::build_list(
|
||||
@@ -1542,6 +1543,9 @@ goos::Object GenericElement::to_form_internal(const Env& env) const {
|
||||
m_head.condition_kind() == IR2_Condition::Kind::TRUTHY) {
|
||||
assert(m_elts.size() == 1);
|
||||
return m_elts.front()->to_form_as_condition(env);
|
||||
} else if (m_head.kind() == GenericOperator::Kind::CONDITION_OPERATOR &&
|
||||
m_head.condition_kind() == IR2_Condition::Kind::ALWAYS) {
|
||||
return pretty_print::to_symbol("#t");
|
||||
} else {
|
||||
std::vector<goos::Object> result;
|
||||
result.push_back(m_head.to_form(env));
|
||||
|
||||
@@ -2059,6 +2059,7 @@ FormElement* ConditionElement::make_generic(const Env& env,
|
||||
case IR2_Condition::Kind::FALSE:
|
||||
case IR2_Condition::Kind::IS_PAIR:
|
||||
case IR2_Condition::Kind::IS_NOT_PAIR:
|
||||
case IR2_Condition::Kind::ALWAYS:
|
||||
// kind of a hack, we fall back to the old condition operator which is special cased
|
||||
// to print the truthy condition in a nice way. and we use it for other things that don't
|
||||
// require fancy renaming.
|
||||
@@ -2285,7 +2286,8 @@ void AtomicOpElement::push_to_stack(const Env& env, FormPool&, FormStack& stack)
|
||||
if (as_special) {
|
||||
if (as_special->kind() == SpecialOp::Kind::NOP ||
|
||||
as_special->kind() == SpecialOp::Kind::BREAK ||
|
||||
as_special->kind() == SpecialOp::Kind::CRASH) {
|
||||
as_special->kind() == SpecialOp::Kind::CRASH ||
|
||||
as_special->kind() == SpecialOp::Kind::SUSPEND) {
|
||||
stack.push_form_element(this, true);
|
||||
return;
|
||||
}
|
||||
|
||||
@@ -140,7 +140,7 @@ std::unique_ptr<AtomicOp> make_standard_load(const Instruction& i0,
|
||||
int idx,
|
||||
int load_size,
|
||||
LoadVarOp::Kind kind) {
|
||||
if (i0.get_dst(0).is_reg(rra())) {
|
||||
if (i0.get_dst(0).is_reg(rra()) || i0.get_dst(0).is_reg(Register(Reg::GPR, Reg::SP))) {
|
||||
return std::make_unique<AsmOp>(i0, idx);
|
||||
}
|
||||
auto dst = make_dst_var(i0, idx);
|
||||
@@ -164,6 +164,9 @@ std::unique_ptr<AtomicOp> make_standard_store(const Instruction& i0,
|
||||
int idx,
|
||||
int store_size,
|
||||
bool is_float) {
|
||||
if (i0.get_src(2).is_reg(Register(Reg::GPR, Reg::SP))) {
|
||||
return std::make_unique<AsmOp>(i0, idx);
|
||||
}
|
||||
SimpleAtom val;
|
||||
SimpleExpression dst;
|
||||
if (i0.get_src(0).is_reg(rs7())) {
|
||||
|
||||
@@ -107,6 +107,12 @@
|
||||
"string-cat-to-last-char": [
|
||||
[3, "s5", "(pointer uint8)"],
|
||||
[4, "s5", "string"]
|
||||
],
|
||||
|
||||
|
||||
// GSTATE
|
||||
"enter-state":[
|
||||
[68, "s0", "protect-frame"]
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@@ -73,4 +73,11 @@
|
||||
(define-extern *default-pool* process-tree)
|
||||
(define-extern *stdcon0* string)
|
||||
(define-extern *stdcon1* string)
|
||||
(define-extern *debug-draw-pauseable* symbol)
|
||||
(define-extern *debug-draw-pauseable* symbol)
|
||||
|
||||
;; gstate
|
||||
(define-extern enter-state (function object object object object object object object))
|
||||
(define-extern throw (function symbol object int))
|
||||
(defmacro suspend()
|
||||
'(none)
|
||||
)
|
||||
@@ -0,0 +1,49 @@
|
||||
;;-*-Lisp-*-
|
||||
(in-package goal)
|
||||
|
||||
;; definition of type dgo-entry
|
||||
(deftype dgo-entry (structure)
|
||||
((offset uint32 :offset-assert 0)
|
||||
(length uint32 :offset-assert 4)
|
||||
)
|
||||
:method-count-assert 9
|
||||
:size-assert #x8
|
||||
:flag-assert #x900000008
|
||||
)
|
||||
|
||||
;; definition for method 3 of type dgo-entry
|
||||
(defmethod inspect dgo-entry ((obj dgo-entry))
|
||||
(format #t "[~8x] ~A~%" obj 'dgo-entry)
|
||||
(format #t "~Toffset: ~D~%" (-> obj offset))
|
||||
(format #t "~Tlength: ~D~%" (-> obj length))
|
||||
obj
|
||||
)
|
||||
|
||||
;; definition of type dgo-file
|
||||
(deftype dgo-file (basic)
|
||||
((num-go-files uint32 :offset-assert 4)
|
||||
(total-length uint32 :offset-assert 8)
|
||||
(rsvd uint32 :offset-assert 12)
|
||||
(data uint8 :dynamic :offset-assert 16)
|
||||
)
|
||||
:method-count-assert 9
|
||||
:size-assert #x10
|
||||
:flag-assert #x900000010
|
||||
)
|
||||
|
||||
;; definition for method 3 of type dgo-file
|
||||
(defmethod inspect dgo-file ((obj dgo-file))
|
||||
(format #t "[~8x] ~A~%" obj (-> obj type))
|
||||
(format #t "~Tnum-go-files: ~D~%" (-> obj num-go-files))
|
||||
(format #t "~Ttotal-length: ~D~%" (-> obj total-length))
|
||||
(format #t "~Trsvd: ~D~%" (-> obj rsvd))
|
||||
(format #t "~Tdata[0] @ #x~X~%" (-> obj data))
|
||||
obj
|
||||
)
|
||||
|
||||
;; failed to figure out what this is:
|
||||
(let ((v0-2 0))
|
||||
)
|
||||
|
||||
;; failed to figure out what this is:
|
||||
(none)
|
||||
@@ -87,10 +87,14 @@
|
||||
)
|
||||
|
||||
;; definition for function false-func
|
||||
(defun false-func () #f)
|
||||
(defun false-func ()
|
||||
#f
|
||||
)
|
||||
|
||||
;; definition for function true-func
|
||||
(defun true-func () #t)
|
||||
(defun true-func ()
|
||||
#t
|
||||
)
|
||||
|
||||
;; definition for symbol format, type (function _varargs_ object)
|
||||
(define format _format)
|
||||
@@ -1066,8 +1070,7 @@
|
||||
((not expected-type)
|
||||
(cond
|
||||
((nonzero? (logand (the-as int obj) 3))
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object (misaligned)~%"
|
||||
@@ -1078,8 +1081,7 @@
|
||||
#f
|
||||
)
|
||||
((not in-goal-mem)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object (bad address)~%"
|
||||
@@ -1102,8 +1104,7 @@
|
||||
((= expected-type structure)
|
||||
(cond
|
||||
((nonzero? (logand (the-as int obj) 15))
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%"
|
||||
@@ -1121,8 +1122,7 @@
|
||||
(< (the-as uint obj) (the-as uint v1-11))
|
||||
)
|
||||
)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%"
|
||||
@@ -1141,8 +1141,7 @@
|
||||
((= expected-type pair)
|
||||
(cond
|
||||
((!= (logand (the-as int obj) 7) 2)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%"
|
||||
@@ -1154,8 +1153,7 @@
|
||||
#f
|
||||
)
|
||||
((not in-goal-mem)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%"
|
||||
@@ -1177,8 +1175,7 @@
|
||||
#t
|
||||
)
|
||||
(else
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%"
|
||||
@@ -1192,8 +1189,7 @@
|
||||
)
|
||||
)
|
||||
((!= (logand (the-as int obj) 7) 4)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%"
|
||||
@@ -1205,8 +1201,7 @@
|
||||
#f
|
||||
)
|
||||
((not in-goal-mem)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%"
|
||||
@@ -1218,8 +1213,7 @@
|
||||
#f
|
||||
)
|
||||
((and (= expected-type type) (!= (rtype-of obj) type))
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
|
||||
@@ -1237,8 +1231,7 @@
|
||||
(!= expected-type type)
|
||||
(not (valid? (rtype-of obj) type #f #t 0))
|
||||
)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
|
||||
@@ -1251,8 +1244,7 @@
|
||||
#f
|
||||
)
|
||||
((not (type-type? (rtype-of obj) expected-type))
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (is type '~A' instead)~%"
|
||||
@@ -1270,8 +1262,7 @@
|
||||
)
|
||||
(cond
|
||||
((>= (the-as uint obj) (the-as uint v1-44))
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (not in symbol table)~%"
|
||||
@@ -1293,8 +1284,7 @@
|
||||
)
|
||||
(< (the-as uint obj) (the-as uint v1-48))
|
||||
)
|
||||
(if
|
||||
name
|
||||
(if name
|
||||
(format
|
||||
print-dest
|
||||
"ERROR: object #x~X ~S is not a valid object of type '~A' (inside symbol table)~%"
|
||||
|
||||
@@ -47,7 +47,8 @@
|
||||
;; definition for function unload-package
|
||||
(defun unload-package ((arg0 string))
|
||||
(let ((v1-0 (nmember arg0 *kernel-packages*)))
|
||||
(if v1-0 (set! *kernel-packages* (delete! (car v1-0) *kernel-packages*))
|
||||
(if v1-0
|
||||
(set! *kernel-packages* (delete! (car v1-0) *kernel-packages*))
|
||||
)
|
||||
)
|
||||
*kernel-packages*
|
||||
@@ -206,13 +207,13 @@
|
||||
)
|
||||
|
||||
;; definition for function remove-exit
|
||||
(defun remove-exit () (local-vars (pp process))
|
||||
(if (-> pp stack-frame-top)
|
||||
(let ((v0-0 (-> pp stack-frame-top next)))
|
||||
(set! (-> pp stack-frame-top) v0-0)
|
||||
v0-0
|
||||
)
|
||||
)
|
||||
(defun remove-exit ()
|
||||
(local-vars (pp process)) (if (-> pp stack-frame-top)
|
||||
(let ((v0-0 (-> pp stack-frame-top next)))
|
||||
(set! (-> pp stack-frame-top) v0-0)
|
||||
v0-0
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; definition (debug) for function stream<-process-mask
|
||||
@@ -335,7 +336,8 @@
|
||||
(a1-3 "~Tparent: ~A~%")
|
||||
(v1-0 (-> obj parent))
|
||||
)
|
||||
(t9-3 a0-4 a1-3 (if v1-0 (-> v1-0 0 self)
|
||||
(t9-3 a0-4 a1-3 (if v1-0
|
||||
(-> v1-0 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -344,7 +346,8 @@
|
||||
(a1-4 "~Tbrother: ~A~%")
|
||||
(v1-2 (-> obj brother))
|
||||
)
|
||||
(t9-4 a0-5 a1-4 (if v1-2 (-> v1-2 0 self)
|
||||
(t9-4 a0-5 a1-4 (if v1-2
|
||||
(-> v1-2 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -353,7 +356,8 @@
|
||||
(a1-5 "~Tchild: ~A~%")
|
||||
(v1-4 (-> obj child))
|
||||
)
|
||||
(t9-5 a0-6 a1-5 (if v1-4 (-> v1-4 0 self)
|
||||
(t9-5 a0-6 a1-5 (if v1-4
|
||||
(-> v1-4 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -445,7 +449,8 @@
|
||||
(a1-12 "~Tparent: ~A~%")
|
||||
(v1-0 (-> obj parent))
|
||||
)
|
||||
(t9-12 a0-13 a1-12 (if v1-0 (-> v1-0 0 self)
|
||||
(t9-12 a0-13 a1-12 (if v1-0
|
||||
(-> v1-0 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -454,7 +459,8 @@
|
||||
(a1-13 "~Tbrother: ~A~%")
|
||||
(v1-2 (-> obj brother))
|
||||
)
|
||||
(t9-13 a0-14 a1-13 (if v1-2 (-> v1-2 0 self)
|
||||
(t9-13 a0-14 a1-13 (if v1-2
|
||||
(-> v1-2 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -463,7 +469,8 @@
|
||||
(a1-14 "~Tchild: ~A~%")
|
||||
(v1-4 (-> obj child))
|
||||
)
|
||||
(t9-14 a0-15 a1-14 (if v1-4 (-> v1-4 0 self)
|
||||
(t9-14 a0-15 a1-14 (if v1-4
|
||||
(-> v1-4 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -554,12 +561,14 @@
|
||||
(v1-5 ((method-of-type process new) allocation process 'dead arg1))
|
||||
)
|
||||
(let ((a0-3 v1-5))
|
||||
(set! (-> s3-0 child) (if a0-3 (-> a0-3 ppointer)
|
||||
(set! (-> s3-0 child) (if a0-3
|
||||
(-> a0-3 ppointer)
|
||||
)
|
||||
)
|
||||
)
|
||||
(let ((a0-4 s3-0))
|
||||
(set! (-> v1-5 parent) (if a0-4 (-> a0-4 ppointer)
|
||||
(set! (-> v1-5 parent) (if a0-4
|
||||
(-> a0-4 ppointer)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -789,15 +798,16 @@
|
||||
(let ((s5-1 (-> obj alive-list))
|
||||
(s4-0 0)
|
||||
)
|
||||
(while s5-1 (if (-> s5-1 process)
|
||||
(format
|
||||
#t
|
||||
"~T [~3D] #<dead-pool-heap-rec @ #x~X> ~A~%"
|
||||
s4-0
|
||||
s5-1
|
||||
(-> s5-1 process)
|
||||
)
|
||||
)
|
||||
(while s5-1
|
||||
(if (-> s5-1 process)
|
||||
(format
|
||||
#t
|
||||
"~T [~3D] #<dead-pool-heap-rec @ #x~X> ~A~%"
|
||||
s4-0
|
||||
s5-1
|
||||
(-> s5-1 process)
|
||||
)
|
||||
)
|
||||
(let ((s3-0 (gap-size obj s5-1)))
|
||||
(if (nonzero? s3-0)
|
||||
(format #t "~T gap: ~D bytes @ #x~X~%" s3-0 (gap-location obj s5-1))
|
||||
@@ -875,7 +885,8 @@
|
||||
(let ((v1-5 (-> s1-0 next)))
|
||||
(set! (-> s1-0 next) s4-0)
|
||||
(set! (-> s4-0 next) v1-5)
|
||||
(when v1-5 (set! (-> v1-5 prev) s4-0)
|
||||
(when v1-5
|
||||
(set! (-> v1-5 prev) s4-0)
|
||||
(let ((v1-6 s4-0))
|
||||
)
|
||||
)
|
||||
@@ -931,7 +942,8 @@
|
||||
)
|
||||
)
|
||||
)
|
||||
(if s3-0 (set! (-> s3-0 type) arg0)
|
||||
(if s3-0
|
||||
(set! (-> s3-0 type) arg0)
|
||||
(format
|
||||
0
|
||||
"WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
|
||||
@@ -990,41 +1002,30 @@
|
||||
|
||||
;; definition for method 17 of type dead-pool-heap
|
||||
(defmethod shrink-heap dead-pool-heap ((obj dead-pool-heap) (arg0 process))
|
||||
(if arg0 (let ((s5-0 (-> arg0 ppointer)))
|
||||
(when
|
||||
(not
|
||||
(or
|
||||
(nonzero? (logand (-> arg0 mask) 512))
|
||||
(and (not (-> arg0 next-state)) (not (-> arg0 state)))
|
||||
)
|
||||
)
|
||||
(set!
|
||||
(-> arg0 allocated-length)
|
||||
(&- (-> arg0 heap-cur) (the-as uint (-> arg0 stack)))
|
||||
)
|
||||
(set!
|
||||
(-> arg0 heap-top)
|
||||
(&-> arg0 stack (-> arg0 allocated-length))
|
||||
)
|
||||
(if
|
||||
(<
|
||||
(the-as int arg0)
|
||||
(the-as int (gap-location obj (-> obj first-gap)))
|
||||
)
|
||||
(set!
|
||||
(-> obj first-gap)
|
||||
(find-gap obj (the-as dead-pool-heap-rec s5-0))
|
||||
)
|
||||
)
|
||||
(set! (-> arg0 mask) (logior (-> arg0 mask) 512))
|
||||
)
|
||||
(if (= (-> obj first-shrink) s5-0)
|
||||
(set!
|
||||
(-> obj first-shrink)
|
||||
(the-as dead-pool-heap-rec (-> s5-0 2))
|
||||
)
|
||||
)
|
||||
)
|
||||
(if arg0
|
||||
(let ((s5-0 (-> arg0 ppointer)))
|
||||
(when
|
||||
(not
|
||||
(or
|
||||
(nonzero? (logand (-> arg0 mask) 512))
|
||||
(and (not (-> arg0 next-state)) (not (-> arg0 state)))
|
||||
)
|
||||
)
|
||||
(set!
|
||||
(-> arg0 allocated-length)
|
||||
(&- (-> arg0 heap-cur) (the-as uint (-> arg0 stack)))
|
||||
)
|
||||
(set! (-> arg0 heap-top) (&-> arg0 stack (-> arg0 allocated-length)))
|
||||
(if
|
||||
(< (the-as int arg0) (the-as int (gap-location obj (-> obj first-gap))))
|
||||
(set! (-> obj first-gap) (find-gap obj (the-as dead-pool-heap-rec s5-0)))
|
||||
)
|
||||
(set! (-> arg0 mask) (logior (-> arg0 mask) 512))
|
||||
)
|
||||
(if (= (-> obj first-shrink) s5-0)
|
||||
(set! (-> obj first-shrink) (the-as dead-pool-heap-rec (-> s5-0 2)))
|
||||
)
|
||||
)
|
||||
)
|
||||
obj
|
||||
)
|
||||
@@ -1067,7 +1068,8 @@
|
||||
(let ((a0-5 v1-13))
|
||||
)
|
||||
)
|
||||
(if v1-13 (shrink-heap obj (-> v1-13 process))
|
||||
(if v1-13
|
||||
(shrink-heap obj (-> v1-13 process))
|
||||
)
|
||||
)
|
||||
(let ((s4-1 (-> obj first-gap)))
|
||||
@@ -1101,8 +1103,7 @@
|
||||
(while (nonzero? arg0)
|
||||
(+! arg0 -1)
|
||||
(let ((s4-0 (-> obj alive-list next)))
|
||||
(when
|
||||
s4-0
|
||||
(when s4-0
|
||||
(if
|
||||
(or
|
||||
(= (-> obj first-gap) s4-0)
|
||||
@@ -1128,7 +1129,8 @@
|
||||
(let ((v1-19 (-> a1-3 next)))
|
||||
(set! (-> a1-3 next) s4-0)
|
||||
(set! (-> s4-0 next) v1-19)
|
||||
(when v1-19 (set! (-> v1-19 prev) s4-0)
|
||||
(when v1-19
|
||||
(set! (-> v1-19 prev) s4-0)
|
||||
(let ((v1-20 s4-0))
|
||||
)
|
||||
)
|
||||
@@ -1277,10 +1279,11 @@
|
||||
)
|
||||
(else
|
||||
(let ((v1-4 (-> arg0 child)))
|
||||
(while v1-4 (let ((s3-1 (-> v1-4 0 brother)))
|
||||
(iterate-process-tree (-> v1-4 0) arg1 arg2)
|
||||
(set! v1-4 s3-1)
|
||||
)
|
||||
(while v1-4
|
||||
(let ((s3-1 (-> v1-4 0 brother)))
|
||||
(iterate-process-tree (-> v1-4 0) arg1 arg2)
|
||||
(set! v1-4 s3-1)
|
||||
)
|
||||
(let ((a0-4 v1-4))
|
||||
)
|
||||
)
|
||||
@@ -1314,10 +1317,11 @@
|
||||
)
|
||||
(else
|
||||
(let ((v1-8 (-> arg0 child)))
|
||||
(while v1-8 (let ((s4-1 (-> v1-8 0 brother)))
|
||||
(execute-process-tree (-> v1-8 0) arg1 arg2)
|
||||
(set! v1-8 s4-1)
|
||||
)
|
||||
(while v1-8
|
||||
(let ((s4-1 (-> v1-8 0 brother)))
|
||||
(execute-process-tree (-> v1-8 0) arg1 arg2)
|
||||
(set! v1-8 s4-1)
|
||||
)
|
||||
(let ((a0-6 v1-8))
|
||||
)
|
||||
)
|
||||
@@ -1339,13 +1343,15 @@
|
||||
)
|
||||
)
|
||||
(let ((v1-5 (-> arg0 child)))
|
||||
(while v1-5 (let ((s5-1 (-> v1-5 0 brother)))
|
||||
(let ((v1-6 (search-process-tree (-> v1-5 0) arg1)))
|
||||
(if v1-6 (return v1-6)
|
||||
)
|
||||
)
|
||||
(set! v1-5 s5-1)
|
||||
)
|
||||
(while v1-5
|
||||
(let ((s5-1 (-> v1-5 0 brother)))
|
||||
(let ((v1-6 (search-process-tree (-> v1-5 0) arg1)))
|
||||
(if v1-6
|
||||
(return v1-6)
|
||||
)
|
||||
)
|
||||
(set! v1-5 s5-1)
|
||||
)
|
||||
(let ((a0-5 v1-5))
|
||||
)
|
||||
)
|
||||
@@ -1354,10 +1360,9 @@
|
||||
)
|
||||
|
||||
;; definition for function kernel-dispatcher
|
||||
(defun
|
||||
kernel-dispatcher
|
||||
()
|
||||
(when *listener-function* (set! *enable-method-set* (+ *enable-method-set* 1))
|
||||
(defun kernel-dispatcher ()
|
||||
(when *listener-function*
|
||||
(set! *enable-method-set* (+ *enable-method-set* 1))
|
||||
(let
|
||||
((t1-0
|
||||
(reset-and-call (-> *listener-process* main-thread) *listener-function*)
|
||||
@@ -1498,8 +1503,7 @@
|
||||
)
|
||||
)
|
||||
(let ((s2-1 (-> arg0 child)))
|
||||
(while
|
||||
s2-1
|
||||
(while s2-1
|
||||
(inspect-process-tree (-> s2-1 0) (+ arg1 1) (if (not (-> s2-1 0 brother))
|
||||
arg2
|
||||
(let* ((v1-7 1)
|
||||
@@ -1547,16 +1551,18 @@
|
||||
;; INFO: Return type mismatch (pointer process-tree) vs object.
|
||||
(defun previous-brother ((proc process-tree))
|
||||
(let ((parent (-> proc parent)))
|
||||
(when parent (let ((child (-> parent 0 child)))
|
||||
(if (= child proc)
|
||||
(return #f)
|
||||
)
|
||||
(while child (if (= (-> child 0 brother) proc)
|
||||
(return child)
|
||||
)
|
||||
(set! child (-> child 0 brother))
|
||||
)
|
||||
)
|
||||
(when parent
|
||||
(let ((child (-> parent 0 child)))
|
||||
(if (= child proc)
|
||||
(return #f)
|
||||
)
|
||||
(while child
|
||||
(if (= (-> child 0 brother) proc)
|
||||
(return child)
|
||||
)
|
||||
(set! child (-> child 0 brother))
|
||||
)
|
||||
)
|
||||
#f
|
||||
)
|
||||
)
|
||||
@@ -1565,32 +1571,35 @@
|
||||
;; definition for function change-parent
|
||||
(defun change-parent ((arg0 process-tree) (arg1 process-tree))
|
||||
(let ((a2-0 (-> arg0 parent)))
|
||||
(if a2-0 (let* ((v1-2 (-> a2-0 0 child))
|
||||
(a3-0 v1-2)
|
||||
)
|
||||
(cond
|
||||
((= (if a3-0 (-> a3-0 0 self)
|
||||
)
|
||||
(if a2-0
|
||||
(let* ((v1-2 (-> a2-0 0 child))
|
||||
(a3-0 v1-2)
|
||||
)
|
||||
(cond
|
||||
((= (if a3-0
|
||||
(-> a3-0 0 self)
|
||||
)
|
||||
arg0
|
||||
)
|
||||
(set! (-> a2-0 0 child) (-> arg0 brother))
|
||||
)
|
||||
(else
|
||||
(while (let ((a2-2 (-> v1-2 0 brother)))
|
||||
(!= (if a2-2
|
||||
(-> a2-2 0 self)
|
||||
)
|
||||
arg0
|
||||
)
|
||||
(set! (-> a2-0 0 child) (-> arg0 brother))
|
||||
)
|
||||
(else
|
||||
(while (let ((a2-2 (-> v1-2 0 brother)))
|
||||
(!= (if a2-2 (-> a2-2 0 self)
|
||||
)
|
||||
arg0
|
||||
)
|
||||
)
|
||||
(nop!)
|
||||
(nop!)
|
||||
(nop!)
|
||||
(set! v1-2 (-> v1-2 0 brother))
|
||||
)
|
||||
(set! (-> v1-2 0 brother) (-> arg0 brother))
|
||||
)
|
||||
)
|
||||
)
|
||||
(nop!)
|
||||
(nop!)
|
||||
(nop!)
|
||||
(set! v1-2 (-> v1-2 0 brother))
|
||||
)
|
||||
(set! (-> v1-2 0 brother) (-> arg0 brother))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(set! (-> arg0 parent) (-> arg1 ppointer))
|
||||
@@ -1603,81 +1612,80 @@
|
||||
(defun change-brother ((arg0 process-tree) (arg1 process-tree))
|
||||
(if (and arg0 (!= (-> arg0 brother) arg1) (!= arg0 arg1))
|
||||
(let ((a2-1 (-> arg0 parent)))
|
||||
(if a2-1 (let ((t0-0 (-> a2-1 0 child))
|
||||
(a3-1 (the-as (pointer process-tree) #f))
|
||||
(v1-4 (the-as (pointer process-tree) #f))
|
||||
)
|
||||
(let ((t1-0 t0-0))
|
||||
(when (= (if t1-0 (-> t1-0 0 self)
|
||||
)
|
||||
arg0
|
||||
)
|
||||
(set! a3-1 a2-1)
|
||||
(let ((t1-3 a3-1))
|
||||
(if a2-1
|
||||
(let ((t0-0 (-> a2-1 0 child))
|
||||
(a3-1 (the-as (pointer process-tree) #f))
|
||||
(v1-4 (the-as (pointer process-tree) #f))
|
||||
)
|
||||
(let ((t1-0 t0-0))
|
||||
(when (= (if t1-0
|
||||
(-> t1-0 0 self)
|
||||
)
|
||||
)
|
||||
)
|
||||
(let ((t1-4 t0-0))
|
||||
(when (= (if t1-4 (-> t1-4 0 self)
|
||||
)
|
||||
arg1
|
||||
)
|
||||
(set! v1-4 a2-1)
|
||||
(let ((t1-7 v1-4))
|
||||
)
|
||||
)
|
||||
)
|
||||
(while (and (-> t0-0 0 brother) (or (not a3-1) (not v1-4)))
|
||||
(let ((t1-8 t0-0))
|
||||
(when (= (-> (if t1-8 (-> t1-8 0 self)
|
||||
)
|
||||
brother
|
||||
)
|
||||
arg1
|
||||
)
|
||||
(set! v1-4 t0-0)
|
||||
(let ((t1-12 v1-4))
|
||||
)
|
||||
)
|
||||
)
|
||||
(let ((t1-13 t0-0))
|
||||
(when (= (-> (if t1-13 (-> t1-13 0 self)
|
||||
)
|
||||
brother
|
||||
)
|
||||
arg0
|
||||
)
|
||||
(set! a3-1 t0-0)
|
||||
(let ((t1-17 a3-1))
|
||||
)
|
||||
)
|
||||
)
|
||||
(set! t0-0 (-> t0-0 0 brother))
|
||||
)
|
||||
(if (or (not a3-1) (not v1-4))
|
||||
(return 0)
|
||||
(if (= a3-1 a2-1)
|
||||
(set! (-> a3-1 4) (the-as process-tree (-> arg0 brother)))
|
||||
(set! (-> a3-1 3) (the-as process-tree (-> arg0 brother)))
|
||||
)
|
||||
)
|
||||
(cond
|
||||
((= v1-4 a2-1)
|
||||
(set!
|
||||
(-> arg0 brother)
|
||||
(the-as (pointer process-tree) (-> v1-4 4))
|
||||
)
|
||||
(set! (-> v1-4 4) (the-as process-tree (-> arg0 ppointer)))
|
||||
)
|
||||
(else
|
||||
(set!
|
||||
(-> arg0 brother)
|
||||
(the-as (pointer process-tree) (-> v1-4 3))
|
||||
)
|
||||
(set! (-> v1-4 3) (the-as process-tree (-> arg0 ppointer)))
|
||||
)
|
||||
)
|
||||
arg0
|
||||
)
|
||||
(set! a3-1 a2-1)
|
||||
(let ((t1-3 a3-1))
|
||||
)
|
||||
)
|
||||
)
|
||||
(let ((t1-4 t0-0))
|
||||
(when (= (if t1-4
|
||||
(-> t1-4 0 self)
|
||||
)
|
||||
arg1
|
||||
)
|
||||
(set! v1-4 a2-1)
|
||||
(let ((t1-7 v1-4))
|
||||
)
|
||||
)
|
||||
)
|
||||
(while (and (-> t0-0 0 brother) (or (not a3-1) (not v1-4)))
|
||||
(let ((t1-8 t0-0))
|
||||
(when (= (-> (if t1-8
|
||||
(-> t1-8 0 self)
|
||||
)
|
||||
brother
|
||||
)
|
||||
arg1
|
||||
)
|
||||
(set! v1-4 t0-0)
|
||||
(let ((t1-12 v1-4))
|
||||
)
|
||||
)
|
||||
)
|
||||
(let ((t1-13 t0-0))
|
||||
(when (= (-> (if t1-13
|
||||
(-> t1-13 0 self)
|
||||
)
|
||||
brother
|
||||
)
|
||||
arg0
|
||||
)
|
||||
(set! a3-1 t0-0)
|
||||
(let ((t1-17 a3-1))
|
||||
)
|
||||
)
|
||||
)
|
||||
(set! t0-0 (-> t0-0 0 brother))
|
||||
)
|
||||
(if (or (not a3-1) (not v1-4))
|
||||
(return 0)
|
||||
(if (= a3-1 a2-1)
|
||||
(set! (-> a3-1 4) (the-as process-tree (-> arg0 brother)))
|
||||
(set! (-> a3-1 3) (the-as process-tree (-> arg0 brother)))
|
||||
)
|
||||
)
|
||||
(cond
|
||||
((= v1-4 a2-1)
|
||||
(set! (-> arg0 brother) (the-as (pointer process-tree) (-> v1-4 4)))
|
||||
(set! (-> v1-4 4) (the-as process-tree (-> arg0 ppointer)))
|
||||
)
|
||||
(else
|
||||
(set! (-> arg0 brother) (the-as (pointer process-tree) (-> v1-4 3)))
|
||||
(set! (-> v1-4 3) (the-as process-tree (-> arg0 ppointer)))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -1852,12 +1860,13 @@
|
||||
(let ((v0-2 (process-disconnect obj))
|
||||
(v1-11 (-> obj child))
|
||||
)
|
||||
(while v1-11 (let ((s5-1 (-> v1-11 0 brother)))
|
||||
(deactivate (-> v1-11 0))
|
||||
(let ((v1-13 v0-2))
|
||||
)
|
||||
(set! v1-11 s5-1)
|
||||
)
|
||||
(while v1-11
|
||||
(let ((s5-1 (-> v1-11 0 brother)))
|
||||
(deactivate (-> v1-11 0))
|
||||
(let ((v1-13 v0-2))
|
||||
)
|
||||
(set! v1-11 s5-1)
|
||||
)
|
||||
(let ((a0-8 v1-11))
|
||||
)
|
||||
)
|
||||
@@ -1931,8 +1940,7 @@
|
||||
)
|
||||
|
||||
;; failed to figure out what this is:
|
||||
(if
|
||||
*debug-segment*
|
||||
(if *debug-segment*
|
||||
(set!
|
||||
*debug-dead-pool*
|
||||
(new 'debug 'dead-pool-heap '*debug-dead-pool* 768 #x100000)
|
||||
@@ -2011,4 +2019,4 @@
|
||||
)
|
||||
|
||||
;; failed to figure out what this is:
|
||||
(none)
|
||||
(none)
|
||||
@@ -0,0 +1,168 @@
|
||||
;;-*-Lisp-*-
|
||||
(in-package goal)
|
||||
|
||||
;; definition for method 0 of type state
|
||||
(defmethod
|
||||
new
|
||||
state
|
||||
((allocation symbol)
|
||||
(type-to-make type)
|
||||
(name basic)
|
||||
(code function)
|
||||
(trans (function object))
|
||||
(enter (function object object object object object object object))
|
||||
(exit (function object))
|
||||
(event (function basic int basic event-message-block object))
|
||||
)
|
||||
(let
|
||||
((obj
|
||||
(object-new allocation type-to-make (the-as int (-> type-to-make size)))
|
||||
)
|
||||
)
|
||||
(set! (-> obj name) name)
|
||||
(set! (-> obj next) #f)
|
||||
(set! (-> obj exit) exit)
|
||||
(set! (-> obj code) code)
|
||||
(set! (-> obj trans) trans)
|
||||
(set! (-> obj post) #f)
|
||||
(set! (-> obj enter) enter)
|
||||
(set! (-> obj event) event)
|
||||
obj
|
||||
)
|
||||
)
|
||||
|
||||
;; definition for function inherit-state
|
||||
(defun inherit-state ((arg0 state) (arg1 state))
|
||||
(set! (-> arg0 exit) (-> arg1 exit))
|
||||
(set! (-> arg0 code) (-> arg1 code))
|
||||
(set! (-> arg0 trans) (-> arg1 trans))
|
||||
(set! (-> arg0 post) (-> arg1 post))
|
||||
(set! (-> arg0 enter) (-> arg1 enter))
|
||||
(set! (-> arg0 event) (-> arg1 event))
|
||||
arg0
|
||||
)
|
||||
|
||||
;; definition for method 2 of type state
|
||||
(defmethod print state ((obj state))
|
||||
(format #t "#<~A ~A @ #x~X>" (-> obj type) (-> obj name) obj)
|
||||
obj
|
||||
)
|
||||
|
||||
;; definition for function enter-state
|
||||
;; WARN: Unsupported inline assembly instruction kind - [23]
|
||||
;; WARN: Unsupported inline assembly instruction kind - [22]
|
||||
;; WARN: Unsupported inline assembly instruction kind - [59]
|
||||
;; WARN: Unsupported inline assembly instruction kind - [13]
|
||||
(defun
|
||||
enter-state
|
||||
((arg0 object)
|
||||
(arg1 object)
|
||||
(arg2 object)
|
||||
(arg3 object)
|
||||
(arg4 object)
|
||||
(arg5 object)
|
||||
)
|
||||
(local-vars (pp process) (s7-0 none) (sp-0 none) (sp-1 int) (ra-0 int))
|
||||
(set! (-> pp mask) (logand -193 (the-as int (-> pp mask))))
|
||||
(set! (-> pp mask) (logior (-> pp mask) 1024))
|
||||
(cond
|
||||
((= (-> pp status) 'initialize)
|
||||
(set! (-> pp trans-hook) #f)
|
||||
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
|
||||
(set! (-> pp status) 'initialize-go)
|
||||
(throw 'initialize #t)
|
||||
#t
|
||||
)
|
||||
((!= (-> *kernel-context* current-process) pp)
|
||||
(let ((s0-0 (-> pp status)))
|
||||
(set! (-> pp trans-hook) #f)
|
||||
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
|
||||
(set! (-> pp status) s0-0)
|
||||
)
|
||||
#t
|
||||
)
|
||||
((= (-> pp main-thread) (-> pp top-thread))
|
||||
(set! (-> pp state) (-> pp next-state))
|
||||
(let ((s0-1 (-> pp stack-frame-top)))
|
||||
(while s0-1
|
||||
(let ((v1-10 (-> s0-1 type)))
|
||||
(if (or (= v1-10 protect-frame) (= v1-10 state))
|
||||
((-> (the-as protect-frame s0-1) exit))
|
||||
)
|
||||
)
|
||||
(set! s0-1 (-> s0-1 next))
|
||||
)
|
||||
)
|
||||
(set! (-> pp mask) (logand -1025 (the-as int (-> pp mask))))
|
||||
(let ((s0-2 (-> pp state)))
|
||||
(set! (-> pp event-hook) (-> s0-2 event))
|
||||
(cond
|
||||
((-> s0-2 exit)
|
||||
(set! (-> pp stack-frame-top) s0-2)
|
||||
(let ((v1-20 s0-2))
|
||||
)
|
||||
)
|
||||
(else
|
||||
(set! (-> pp stack-frame-top) #f)
|
||||
)
|
||||
)
|
||||
(set! (-> pp post-hook) (-> s0-2 post))
|
||||
(set! (-> pp trans-hook) (-> s0-2 trans))
|
||||
(let ((t9-4 (-> s0-2 enter)))
|
||||
(if t9-4
|
||||
(t9-4 arg0 arg1 arg2 arg3 arg4 arg5)
|
||||
)
|
||||
)
|
||||
(let ((t9-5 (-> s0-2 trans)))
|
||||
(if t9-5
|
||||
(t9-5)
|
||||
)
|
||||
)
|
||||
(let ((v1-28 (-> pp main-thread)))
|
||||
(.lwu sp-1 28 v1-28)
|
||||
)
|
||||
(let ((t9-6 (-> s0-2 code)))
|
||||
(.lw ra-0 return-from-thread-dead s7-0)
|
||||
(.jr t9-6)
|
||||
)
|
||||
)
|
||||
arg4
|
||||
)
|
||||
(else
|
||||
(set! (-> pp trans-hook) #f)
|
||||
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
|
||||
(if (!= (-> pp top-thread name) 'post)
|
||||
(let ((v0-2 (the-as object return-from-thread)))
|
||||
(.sw (the-as (function none) v0-2) 0 sp-0)
|
||||
v0-2
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; definition for function send-event-function
|
||||
(defun send-event-function ((arg0 process) (arg1 event-message-block))
|
||||
(when (and arg0 (!= (-> arg0 type) process-tree) (-> arg0 event-hook))
|
||||
(let ((s6-1 arg0))
|
||||
)
|
||||
((-> arg0 event-hook)
|
||||
(-> arg1 from)
|
||||
(-> arg1 num-params)
|
||||
(-> arg1 message)
|
||||
arg1
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; definition for function looping-code
|
||||
;; INFO: Return type mismatch none vs symbol.
|
||||
(defun looping-code ()
|
||||
(while #t
|
||||
(suspend)
|
||||
)
|
||||
(the-as symbol #f)
|
||||
)
|
||||
|
||||
;; failed to figure out what this is:
|
||||
(none)
|
||||
@@ -39,18 +39,19 @@
|
||||
new
|
||||
string
|
||||
((allocation symbol) (type-to-make type) (arg0 int) (arg1 string))
|
||||
(if arg1 (let* ((s2-1 (max ((method-of-type string length) arg1) arg0))
|
||||
(a0-4
|
||||
(object-new
|
||||
allocation
|
||||
type-to-make
|
||||
(+ (+ s2-1 1) (the-as int (-> type-to-make size)))
|
||||
)
|
||||
)
|
||||
)
|
||||
(set! (-> a0-4 allocated-length) s2-1)
|
||||
(copy-string<-string a0-4 arg1)
|
||||
(if arg1
|
||||
(let* ((s2-1 (max ((method-of-type string length) arg1) arg0))
|
||||
(a0-4
|
||||
(object-new
|
||||
allocation
|
||||
type-to-make
|
||||
(+ (+ s2-1 1) (the-as int (-> type-to-make size)))
|
||||
)
|
||||
)
|
||||
)
|
||||
(set! (-> a0-4 allocated-length) s2-1)
|
||||
(copy-string<-string a0-4 arg1)
|
||||
)
|
||||
(let
|
||||
((v0-2
|
||||
(object-new
|
||||
|
||||
@@ -2789,4 +2789,37 @@ TEST_F(FormRegressionTest, TimeToGround) {
|
||||
" (the-as float v0-0)\n"
|
||||
" )";
|
||||
test_with_expr(func, type, expected);
|
||||
}
|
||||
|
||||
// Infinite loop bug (github #196)
|
||||
TEST_F(FormRegressionTest, LoopingCode) {
|
||||
std::string func =
|
||||
"sll r0, r0, 0\n"
|
||||
"L1:\n"
|
||||
" daddiu sp, sp, -16\n"
|
||||
" sd ra, 0(sp)\n"
|
||||
|
||||
"L2:\n"
|
||||
" lwu s6, 44(s6)\n"
|
||||
" mtlo1 s6\n"
|
||||
" lwu s6, 12(s6)\n"
|
||||
" jalr ra, s6\n"
|
||||
" mflo1 s6\n"
|
||||
|
||||
" beq r0, r0, L2\n"
|
||||
" sll r0, r0, 0\n"
|
||||
|
||||
" or v0, s7, r0\n"
|
||||
" ld ra, 0(sp)\n"
|
||||
" jr ra\n"
|
||||
" daddiu sp, sp, 16";
|
||||
std::string type = "(function symbol)";
|
||||
std::string expected =
|
||||
"(begin\n"
|
||||
" (while #t\n"
|
||||
" (suspend)\n"
|
||||
" )\n"
|
||||
" (the-as symbol #f)\n"
|
||||
" )";
|
||||
test_with_expr(func, type, expected);
|
||||
}
|
||||
@@ -10,12 +10,14 @@
|
||||
namespace {
|
||||
// the object files to test
|
||||
const std::unordered_set<std::string> g_object_files_to_decompile = {
|
||||
"gcommon", "gstring-h", "gkernel-h", "gkernel", "gstring"};
|
||||
"gcommon", "gstring-h", "gkernel-h", "gkernel", /*"pskernel",*/ "gstring", "dgo-h", "gstate",
|
||||
};
|
||||
|
||||
// the object files to check against a reference in test/decompiler/reference
|
||||
const std::vector<std::string> g_object_files_to_check_against_reference = {
|
||||
"gcommon", // NOTE: this file needs work, but adding it for now just to test the framework.
|
||||
"gstring-h", "gkernel-h", "gkernel", "gstring"};
|
||||
"gstring-h", "gkernel-h", "gkernel", "gstring", "dgo-h", "gstate",
|
||||
};
|
||||
|
||||
// the functions we expect the decompiler to skip
|
||||
const std::unordered_set<std::string> expected_skip_in_decompiler = {
|
||||
@@ -67,9 +69,13 @@ const std::unordered_set<std::string> skip_in_compiling = {
|
||||
//////////////////////
|
||||
// GKERNEL
|
||||
//////////////////////
|
||||
|
||||
// asm
|
||||
"(method 10 process)"
|
||||
"(method 10 process)",
|
||||
|
||||
//////////////////////
|
||||
// GSTATE
|
||||
//////////////////////
|
||||
"enter-state", // stack pointer asm
|
||||
|
||||
};
|
||||
|
||||
@@ -339,9 +345,9 @@ TEST_F(OfflineDecompilation, Reference) {
|
||||
|
||||
std::string src = db->ir2_final_out(obj_l.at(0));
|
||||
|
||||
// if (file == "gkernel") {
|
||||
// fmt::print("{}\n", src);
|
||||
// }
|
||||
// if (file == "gstate") {
|
||||
// fmt::print("{}\n", src);
|
||||
// }
|
||||
|
||||
auto reference = file_util::read_text_file(file_util::get_file_path(
|
||||
{"test", "decompiler", "reference", fmt::format("{}_REF.gc", file)}));
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
#include "common/goos/Reader.h"
|
||||
#include "common/util/FileUtil.h"
|
||||
#include "common/goos/PrettyPrinter.h"
|
||||
#include "third-party/fmt/core.h"
|
||||
|
||||
using namespace goos;
|
||||
|
||||
@@ -59,4 +60,28 @@ TEST(PrettyPrinter, ReadAgainVeryShortLines) {
|
||||
->car;
|
||||
auto printed_gcommon2 = pretty_print::to_string(gcommon_code);
|
||||
EXPECT_TRUE(gcommon_code == gcommon_code2);
|
||||
}
|
||||
|
||||
TEST(PrettyPrinter, DefunNoArgs) {
|
||||
// wrong old printing
|
||||
std::string code =
|
||||
"(defun looping-code () (while #t (suspend)\n"
|
||||
" )\n"
|
||||
" (the-as symbol #f)\n"
|
||||
" )";
|
||||
|
||||
auto obj = pretty_print::get_pretty_printer_reader()
|
||||
.read_from_string(code)
|
||||
.as_pair()
|
||||
->cdr.as_pair()
|
||||
->car;
|
||||
auto printed = pretty_print::to_string(obj, 80);
|
||||
|
||||
EXPECT_EQ(printed,
|
||||
"(defun looping-code ()\n"
|
||||
" (while #t\n"
|
||||
" (suspend)\n"
|
||||
" )\n"
|
||||
" (the-as symbol #f)\n"
|
||||
" )");
|
||||
}
|
||||
Reference in New Issue
Block a user