fix printing and add gstate (#330)

This commit is contained in:
water111
2021-03-22 20:04:00 -04:00
committed by GitHub
parent 123f3b509d
commit 9ffc6014e1
17 changed files with 675 additions and 265 deletions
+80 -9
View File
@@ -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) {
+2 -1
View File
@@ -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);
+36 -1
View File
@@ -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.
*/
+1
View File
@@ -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;
};
+5 -1
View File
@@ -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));
+3 -1
View File
@@ -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;
}
+4 -1
View File
@@ -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)
)
+49
View File
@@ -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)
+20 -30
View File
@@ -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)~%"
+210 -202
View File
@@ -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)
+168
View File
@@ -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)
+12 -11
View File
@@ -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);
}
+13 -7
View File
@@ -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)}));
+25
View 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"
" )");
}