[Decomp] Decompile gstring (#267)

* decompile gstring

* update

* Update code_status.md

* Update code_status.md

* decompile gstate

* add test for states, hope it passes

* also test throw and catch xmms

* update doc

decompiler/Function/CfgVtx.cpp

@@ -285,6 +285,14 @@ goos::Object Break::to_form() const {
   return pretty_print::build_list(forms);
 }
 
+std::string EmptyVtx::to_string() const {
+  return "empty";
+}
+
+goos::Object EmptyVtx::to_form() const {
+  return pretty_print::build_list("empty");
+}
+
 ControlFlowGraph::ControlFlowGraph() {
   // allocate the entry and exit vertices.
   m_entry = alloc<EntryVtx>();
@@ -1100,6 +1108,7 @@ bool ControlFlowGraph::find_cond_w_else() {
     }
 
     if (!is_found_after(else_block, b0)) {
+      ;
       return true;
     }
 
@@ -1228,6 +1237,185 @@ bool ControlFlowGraph::find_cond_w_else() {
   return found;
 }
 
+bool ControlFlowGraph::find_cond_w_empty_else() {
+  bool found = false;
+
+  for_each_top_level_vtx([&](CfgVtx* vtx) {
+    // determine where the "else" block would be
+    auto* c0 = vtx;       // first condition
+    auto* b0 = c0->next;  // first body
+    if (!b0) {
+      return true;
+    }
+
+    //        printf("cwe try %s %s\n", c0->to_string().c_str(), b0->to_string().c_str());
+
+    // first condition should have the _option_ to fall through to first body
+    if (c0->succ_ft != b0 || c0->end_branch.kind != CfgVtx::DelaySlotKind::NOP) {
+      return true;
+    }
+
+    // first body MUST unconditionally jump to else
+    if (b0->succ_ft || b0->end_branch.branch_likely ||
+        b0->end_branch.kind != CfgVtx::DelaySlotKind::NOP) {
+      return true;
+    }
+
+    if (b0->pred.size() != 1) {
+      return true;
+    }
+
+    assert(b0->end_branch.has_branch);
+    assert(b0->end_branch.branch_always);
+    assert(b0->succ_branch);
+
+    // TODO - check what's in the delay slot!
+    auto* end_block = b0->succ_branch;
+    if (!end_block) {
+      return true;
+    }
+
+    if (!is_found_after(end_block, b0)) {
+      return true;
+    }
+
+    auto* else_block = end_block->prev;
+    if (!else_block) {
+      return true;
+    }
+
+    if (else_block != b0) {
+      return true;
+    } else {
+      else_block = end_block;
+    }
+
+    if (else_block->succ_branch) {
+      return true;
+    }
+
+    assert(!else_block->end_branch.has_branch);
+
+    std::vector<CondWithElse::Entry> entries = {{c0, b0}};
+    auto* prev_condition = c0;
+    auto* prev_body = b0;
+
+    // loop to try to grab all the cases up to the else, or reject if the inside is not sufficiently
+    // compact or if this is not actually a cond with else Note, we are responsible for checking the
+    // branch of prev_condition, but not the fallthrough
+    while (true) {
+      auto* next = prev_body->next;
+      if (next == else_block) {
+        // TODO - check what's in the delay slot!
+        // we're done!
+        // check the prev_condition, prev_body blocks properly go to the else/end_block
+        // prev_condition should jump to else:
+        if (prev_condition->succ_branch != else_block || prev_condition->end_branch.branch_likely ||
+            prev_condition->end_branch.kind != CfgVtx::DelaySlotKind::NOP) {
+          return true;
+        }
+
+        // prev_body should jump to end
+        if (prev_body->succ_branch != end_block ||
+            prev_body->end_branch.kind != CfgVtx::DelaySlotKind::NOP) {
+          return true;
+        }
+
+        break;
+      } else {
+        auto* c = next;
+        auto* b = c->next;
+        if (!c || !b) {
+          ;
+          return true;
+        };
+        // attempt to add another
+
+        if (c->pred.size() != 1) {
+          return true;
+        }
+
+        if (b->pred.size() != 1) {
+          return true;
+        }
+
+        // how to get to cond
+        if (prev_condition->succ_branch != c || prev_condition->end_branch.branch_likely ||
+            prev_condition->end_branch.kind != CfgVtx::DelaySlotKind::NOP) {
+          return true;
+        }
+
+        if (prev_body->end_branch.kind != CfgVtx::DelaySlotKind::NOP) {
+          return true;
+        }
+
+        if (c->succ_ft != b) {
+          return true;  // condition should have the option to fall through if matched
+        }
+
+        // TODO - check what's in the delay slot!
+        if (c->end_branch.branch_likely) {
+          return true;  // otherwise should go to next with a non-likely branch
+        }
+
+        if (b->succ_ft || b->end_branch.branch_likely) {
+          return true;  // body should go straight to else
+        }
+
+        if (b->succ_branch != end_block) {
+          return true;
+        }
+
+        entries.emplace_back(c, b);
+        prev_body = b;
+        prev_condition = c;
+      }
+    }
+
+    // now we need to add it
+    //    printf("got cwe\n");
+    auto new_cwe = alloc<CondWithElse>();
+
+    // link x <-> new_cwe
+    for (auto* npred : c0->pred) {
+      npred->replace_succ_and_check(c0, new_cwe);
+    }
+    new_cwe->pred = c0->pred;
+    new_cwe->prev = c0->prev;
+    if (new_cwe->prev) {
+      new_cwe->prev->next = new_cwe;
+    }
+
+    lg::error("There is a very strange control flow here, please check it manually.");
+
+    // link new_cwe <-> end
+    std::vector<CfgVtx*> to_replace;
+    // to_replace.push_back(else_block);
+    to_replace.push_back(entries.back().condition);
+    for (const auto& x : entries) {
+      to_replace.push_back(x.body);
+    }
+    end_block->replace_preds_with_and_check(to_replace, new_cwe);
+    new_cwe->succ_ft = end_block;
+    new_cwe->next = end_block;
+    end_block->prev = new_cwe;
+
+    // new_cwe->else_vtx = else_block;
+    new_cwe->else_vtx = alloc<EmptyVtx>();
+    new_cwe->entries = std::move(entries);
+
+    new_cwe->else_vtx->parent_claim(new_cwe);
+    for (const auto& x : new_cwe->entries) {
+      x.body->parent_claim(new_cwe);
+      x.condition->parent_claim(new_cwe);
+    }
+    found = true;
+    return false;
+  });
+
+  return found;
+}
+
 #define printf(format, ...) ;
 
 bool ControlFlowGraph::find_cond_n_else() {
@@ -1889,6 +2077,12 @@ std::shared_ptr<ControlFlowGraph> build_cfg(const LinkedObjectFile& file, int se
     if (!changed) {
       changed = changed || cfg->find_goto_not_end();
     }
+
+    if (!changed) {
+      changed = changed || cfg->find_cond_w_empty_else();
+      if (changed) {
+      }
+    }
   }
 
   if (!cfg->is_fully_resolved()) {

decompiler/Function/CfgVtx.h

@@ -270,6 +270,12 @@ class Break : public CfgVtx {
   CfgVtx* unreachable_block = nullptr;
 };
 
+class EmptyVtx : public CfgVtx {
+ public:
+  std::string to_string() const override;
+  goos::Object to_form() const override;
+};
+
 struct BasicBlock;
 
 /*!
@@ -294,6 +300,7 @@ class ControlFlowGraph {
   void link_fall_through_likely(BlockVtx* first, BlockVtx* second, std::vector<BasicBlock>& blocks);
   void link_branch(BlockVtx* first, BlockVtx* second, std::vector<BasicBlock>& blocks);
   bool find_cond_w_else();
+  bool find_cond_w_empty_else();
   bool find_cond_n_else();
 
   //  bool find_if_else_top_level();

decompiler/IR2/AtomicOpForm.cpp

@@ -197,7 +197,7 @@ FormElement* StoreOp::get_as_form(FormPool& pool, const Env& env) const {
         return pool.alloc_element<SetFormFormElement>(addr, val);
       }
 
-      if (input_type.typespec() == TypeSpec("pointer")) {
+      if (input_type.typespec() == TypeSpec("pointer") && ro.offset == 0) {
         std::string cast_type;
         switch (m_size) {
           case 1:

decompiler/IR2/AtomicOpTypeAnalysis.cpp

@@ -540,11 +540,12 @@ TP_Type LoadVarOp::get_src_type(const TypeState& input,
         // remember that we're an object new.
         return TP_Type::make_object_new(method_type);
       }
-      if (method_id == GOAL_NEW_METHOD ||
-          input_type.kind == TP_Type::Kind::TYPE_OF_TYPE_NO_VIRTUAL) {
+      if (method_id == GOAL_NEW_METHOD) {
         return TP_Type::make_from_ts(method_type);
+      } else if (input_type.kind == TP_Type::Kind::TYPE_OF_TYPE_NO_VIRTUAL) {
+        return TP_Type::make_non_virtual_method(method_type);
       } else {
-        return TP_Type::make_method(method_type);
+        return TP_Type::make_virtual_method(method_type);
       }
     }
 
@@ -555,7 +556,8 @@ TP_Type LoadVarOp::get_src_type(const TypeState& input,
       auto method_info = dts.ts.lookup_method("object", method_id);
       if (method_id != GOAL_NEW_METHOD && method_id != GOAL_RELOC_METHOD) {
         // this can get us the wrong thing for `new` methods.  And maybe relocate?
-        return TP_Type::make_from_ts(method_info.type.substitute_for_method_call("object"));
+        return TP_Type::make_non_virtual_method(
+            method_info.type.substitute_for_method_call("object"));
       }
     }
 
@@ -824,7 +826,7 @@ TypeState CallOp::propagate_types_internal(const TypeState& input,
   for (uint32_t i = 0; i < in_type.arg_count() - 1; i++) {
     m_read_regs.emplace_back(Reg::GPR, arg_regs[i]);
     m_arg_vars.push_back(Variable(VariableMode::READ, m_read_regs.back(), m_my_idx));
-    if (i == 0 && in_tp.kind == TP_Type::Kind::METHOD) {
+    if (i == 0 && in_tp.kind == TP_Type::Kind::VIRTUAL_METHOD) {
       m_read_regs.pop_back();
       m_arg_vars.pop_back();
       m_is_virtual_method = true;

decompiler/IR2/Form.h

@@ -127,7 +127,8 @@ class SimpleExpressionElement : public FormElement {
                                     FormPool& pool,
                                     FormStack& stack,
                                     std::vector<FormElement*>* result,
-                                    bool allow_side_effects);
+                                    bool allow_side_effects,
+                                    bool reverse);
   void update_from_stack_force_ui_2(const Env& env,
                                     FixedOperatorKind kind,
                                     FormPool& pool,

decompiler/IR2/FormExpressionAnalysis.cpp

@@ -577,7 +577,8 @@ void SimpleExpressionElement::update_from_stack_force_si_2(const Env& env,
                                                            FormPool& pool,
                                                            FormStack& stack,
                                                            std::vector<FormElement*>* result,
-                                                           bool allow_side_effects) {
+                                                           bool allow_side_effects,
+                                                           bool reverse) {
   auto arg0_i = is_int_type(env, m_my_idx, m_expr.get_arg(0).var());
   bool arg1_i = true;
   bool arg1_reg = m_expr.get_arg(1).is_var();
@@ -589,8 +590,17 @@ void SimpleExpressionElement::update_from_stack_force_si_2(const Env& env,
 
   std::vector<Form*> args;
   if (arg1_reg) {
-    args = pop_to_forms({m_expr.get_arg(0).var(), m_expr.get_arg(1).var()}, env, pool, stack,
-                        allow_side_effects);
+    if (reverse) {
+      args = pop_to_forms({m_expr.get_arg(1).var(), m_expr.get_arg(0).var()}, env, pool, stack,
+                          allow_side_effects);
+      auto temp = args.at(1);
+      args.at(1) = args.at(0);
+      args.at(0) = temp;
+    } else {
+      args = pop_to_forms({m_expr.get_arg(0).var(), m_expr.get_arg(1).var()}, env, pool, stack,
+                          allow_side_effects);
+    }
+
   } else {
     args = pop_to_forms({m_expr.get_arg(0).var()}, env, pool, stack, allow_side_effects);
     args.push_back(pool.alloc_single_element_form<SimpleAtomElement>(nullptr, m_expr.get_arg(1)));
@@ -807,19 +817,19 @@ void SimpleExpressionElement::update_from_stack(const Env& env,
       break;
     case SimpleExpression::Kind::DIV_SIGNED:
       update_from_stack_force_si_2(env, FixedOperatorKind::DIVISION, pool, stack, result,
-                                   allow_side_effects);
+                                   allow_side_effects, false);
       break;
     case SimpleExpression::Kind::MOD_SIGNED:
       update_from_stack_force_si_2(env, FixedOperatorKind::MOD, pool, stack, result,
-                                   allow_side_effects);
+                                   allow_side_effects, false);
       break;
     case SimpleExpression::Kind::MIN_SIGNED:
       update_from_stack_force_si_2(env, FixedOperatorKind::MIN, pool, stack, result,
-                                   allow_side_effects);
+                                   allow_side_effects, false);
       break;
     case SimpleExpression::Kind::MAX_SIGNED:
       update_from_stack_force_si_2(env, FixedOperatorKind::MAX, pool, stack, result,
-                                   allow_side_effects);
+                                   allow_side_effects, false);
       break;
     case SimpleExpression::Kind::AND:
       update_from_stack_copy_first_int_2(env, FixedOperatorKind::LOGAND, pool, stack, result,
@@ -987,7 +997,7 @@ void FunctionCallElement::update_from_stack(const Env& env,
   bool is_method = false;
   auto& tp_type = env.get_types_before_op(all_pop_vars.at(0).idx()).get(all_pop_vars.at(0).reg());
   if (env.has_type_analysis()) {
-    if (tp_type.kind == TP_Type::Kind::METHOD && all_pop_vars.size() >= 1) {
+    if (tp_type.kind == TP_Type::Kind::VIRTUAL_METHOD && all_pop_vars.size() >= 1) {
       is_method = true;
     }
     function_type = tp_type.typespec();
@@ -1002,7 +1012,15 @@ void FunctionCallElement::update_from_stack(const Env& env,
   //    all_pop_vars.erase(all_pop_vars.begin() + 1);
   //  }
 
+  if (tp_type.kind == TP_Type::Kind::NON_VIRTUAL_METHOD) {
+    std::swap(all_pop_vars.at(0), all_pop_vars.at(1));
+  }
   auto unstacked = pop_to_forms(all_pop_vars, env, pool, stack, allow_side_effects);
+  if (tp_type.kind == TP_Type::Kind::NON_VIRTUAL_METHOD) {
+    std::swap(unstacked.at(0), unstacked.at(1));
+    std::swap(all_pop_vars.at(0), all_pop_vars.at(1));
+  }
+
   std::vector<Form*> arg_forms;
 
   for (size_t arg_id = 0; arg_id < nargs; arg_id++) {
@@ -1200,7 +1218,12 @@ void FunctionCallElement::update_from_stack(const Env& env,
           //          temp_form->to_string(env));
         }
       } else {
-        throw std::runtime_error("Method call detected, not yet implemented");
+        auto ti = env.dts->ts.lookup_type(type_1);
+        auto is_basic = dynamic_cast<BasicType*>(ti);
+        if (!is_basic) {
+          throw std::runtime_error(
+              fmt::format("Method call detected, not yet implemented {} {}\n", name, type_1));
+        }
       }
     }
   }
@@ -1743,24 +1766,47 @@ void ConditionElement::update_from_stack(const Env& env,
                                          FormStack& stack,
                                          std::vector<FormElement*>* result,
                                          bool allow_side_effects) {
-  std::vector<Form*> source_forms;
+  std::vector<Form*> source_forms, popped_forms;
   std::vector<TypeSpec> source_types;
   std::vector<Variable> vars;
 
   for (int i = 0; i < get_condition_num_args(m_kind); i++) {
-    auto& var = m_src[i]->var();
-    vars.push_back(var);
-    source_types.push_back(env.get_types_before_op(var.idx()).get(var.reg()).typespec());
+    if (m_src[i]->is_var()) {
+      auto& var = m_src[i]->var();
+      vars.push_back(var);
+      source_types.push_back(env.get_types_before_op(var.idx()).get(var.reg()).typespec());
+    } else if (m_src[i]->is_int()) {
+      if (m_src[i]->get_int() == 0 && condition_uses_float(m_kind)) {
+        // if we're doing a floating point comparison, and one of our arguments is a constant
+        // which is an "integer zero", treat it as a floating point zero.
+        source_types.push_back(TypeSpec("float"));
+      } else {
+        source_types.push_back(TypeSpec("int"));
+      }
+    } else {
+      throw std::runtime_error("Unsupported atom in ConditionElement::push_to_stack");
+    }
   }
-
   if (m_flipped) {
     std::reverse(vars.begin(), vars.end());
   }
-  source_forms = pop_to_forms(vars, env, pool, stack, allow_side_effects, m_consumed);
+
+  popped_forms = pop_to_forms(vars, env, pool, stack, allow_side_effects, m_consumed);
   if (m_flipped) {
-    std::reverse(source_forms.begin(), source_forms.end());
+    std::reverse(popped_forms.begin(), popped_forms.end());
   }
 
+  int popped_counter = 0;
+  for (int i = 0; i < get_condition_num_args(m_kind); i++) {
+    if (m_src[i]->is_var()) {
+      source_forms.push_back(popped_forms.at(popped_counter++));
+    } else {
+      source_forms.push_back(pool.alloc_single_element_form<SimpleAtomElement>(nullptr, *m_src[i]));
+    }
+  }
+  assert(popped_counter == int(popped_forms.size()));
+  assert(source_forms.size() == source_types.size());
+
   result->push_back(make_generic(env, pool, source_forms, source_types));
 }
 

decompiler/analysis/cfg_builder.cpp

@@ -1463,6 +1463,8 @@ Form* cfg_to_ir(FormPool& pool, Function& f, const CfgVtx* vtx) {
         nullptr, cfg_to_ir(pool, f, cvtx->body), cfg_to_ir(pool, f, cvtx->unreachable_block));
     clean_up_break(pool, dynamic_cast<BreakElement*>(result->try_as_single_element()));
     return result;
+  } else if (dynamic_cast<const EmptyVtx*>(vtx)) {
+    return pool.alloc_single_element_form<EmptyElement>(nullptr);
   }
 
   throw std::runtime_error("not yet implemented IR conversion.");

decompiler/analysis/final_output.cpp

@@ -95,6 +95,23 @@ std::string final_defun_out(const Function& func,
     append(top_form, pretty_print::build_list(inline_body));
     return pretty_print::to_string(top_form);
   }
+
+  if (func.guessed_name.kind == FunctionName::FunctionKind::UNIDENTIFIED) {
+    std::string def_name = "defun-anon";
+    assert(special_mode == FunctionDefSpecials::NONE);
+    std::vector<goos::Object> top;
+    top.push_back(pretty_print::to_symbol(def_name));
+    top.push_back(pretty_print::to_symbol(func.guessed_name.to_string()));
+    top.push_back(arguments);
+    auto top_form = pretty_print::build_list(top);
+
+    if (var_count > 0) {
+      append(top_form, pretty_print::build_list(var_dec));
+    }
+
+    append(top_form, pretty_print::build_list(inline_body));
+    return pretty_print::to_string(top_form);
+  }
   return "nyi";
 }
 

decompiler/config/all-types.gc

@@ -197,6 +197,7 @@
 (declare-type cpu-thread basic)
 (declare-type state basic)
 (declare-type dead-pool basic)
+(declare-type event-message-block structure)
 
 ;; gkernel-h
 (deftype thread (basic)
@@ -280,9 +281,9 @@
    (state state :offset-assert #x38)
    (trans-hook function :offset-assert #x3c)
    (post-hook function :offset-assert #x40)
-   (event-hook (function stack-frame (function object) function state object) :offset-assert #x44)
+   (event-hook (function basic int basic event-message-block object) :offset-assert #x44)
    (allocated-length int32 :offset-assert #x48)
-   (next-state basic :offset-assert #x4c)
+   (next-state state :offset-assert #x4c)
    (heap-base pointer :offset-assert #x50)
    (heap-top pointer :offset-assert #x54)
    (heap-cur pointer :offset-assert #x58)
@@ -425,11 +426,14 @@
    (trans (function object)  :offset-assert 20)
    (post  function  :offset-assert 24)
    (enter (function object object object object object object object)  :offset-assert 28)
-   (event basic     :offset-assert 32)
+   (event (function basic int basic event-message-block object)     :offset-assert 32)
    )
   (:methods
     (new ((allocation symbol) (type-to-make type) (name basic) (code function) 
-          (trans function) (enter function) (exit (function object)) (event function)) _type_ 0)
+          (trans (function object)) 
+          (enter (function object object object object object object object)) 
+          (exit (function object)) 
+          (event (function basic int basic event-message-block object))) _type_ 0)
     )
   :method-count-assert 9
   :size-assert         #x24
@@ -631,7 +635,7 @@
 (define-extern copy-charp<-charp (function (pointer uint8) (pointer uint8) (pointer uint8)))
 (define-extern cat-string<-string (function string string string))
 (define-extern catn-string<-charp (function string (pointer uint8) int string))
-(define-extern cat-string<-string_to_charp (function string string int (pointer uint8)))
+(define-extern cat-string<-string_to_charp (function string string (pointer uint8) (pointer uint8)))
 (define-extern append-character-to-string (function string uint8 int))
 (define-extern charp-basename (function (pointer uint8) (pointer uint8)))
 (define-extern clear (function string string))
@@ -639,9 +643,9 @@
 (define-extern string>? (function string string symbol))
 (define-extern string<=? (function string string symbol))
 (define-extern string>=? (function string string symbol))
-(define-extern string-skip-to-char (function (pointer uint8) uint8 (pointer uint8)))
+(define-extern string-skip-to-char (function (pointer uint8) uint (pointer uint8)))
 ;; this one might be wrong
-(define-extern string-cat-to-last-char (function uint8 string uint8 (pointer uint8)))
+(define-extern string-cat-to-last-char (function string string uint (pointer uint8)))
 (define-extern string-skip-whitespace (function (pointer uint8) (pointer uint8)))
 (define-extern string-suck-up! (function string (pointer uint8) symbol))
 (define-extern string-strip-leading-whitespace! (function string symbol))
@@ -689,7 +693,7 @@
 ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~;
 
 (define-extern looping-code (function symbol))
-(define-extern send-event-function (function process state object))
+(define-extern send-event-function (function process event-message-block object))
 (define-extern enter-state (function object object object object object object object))
 (define-extern inherit-state (function state state state))
 

decompiler/config/jak1_ntsc_black_label/anonymous_function_types.jsonc

@@ -6,5 +6,9 @@
 		[28, "(function process symbol)"],
 		[30, "(function process symbol)"],
 		[32, "(function process symbol)"]
+	],
+
+	"hud":[
+	    [15, "(function basic int basic event-message-block object)"]
 	]
 }

decompiler/config/jak1_ntsc_black_label/type_hints.jsonc

@@ -105,6 +105,19 @@
 	"name=":[
 		[24, ["a1", "symbol"]],
 		[39, ["a0", "symbol"]]
-	]
+	],
+
+	"string-cat-to-last-char":[
+	    [3, ["s5", "(pointer uint8)"]],
+	    [4, ["s5", "string"]]
+	],
+
+	"string-strip-trailing-whitespace!":[
+	    [15, ["v1", "(pointer uint8)"]]
+	],
+
+	"(anon-function 15 hud)":[
+	    [0, ["s6", "hud"]]
+	    ]
 
 }

decompiler/config/jak1_ntsc_black_label/var_names.jsonc

@@ -236,6 +236,110 @@
 
 	"box-vector-inside?":{
 		"args":["box", "pt"]
+	},
+
+	"string=":{
+		"args":["str-a", "str-b"],
+		"vars":{"a2-0":"a-ptr", "v1-0":"b-ptr"}
+	},
+
+	"string-charp=":{
+		"args":["str", "charp"],
+		"vars":{"v1-0":"str-ptr"}
+	},
+
+	"copyn-string<-charp":{
+		"args":["str", "charp", "len"],
+		"vars":{"a3-0":"i", "v1-0":"str-ptr"}
+	},
+
+	"string<-charp":{
+		"args":["str", "charp"],
+		"vars":{"v1-0":"str-ptr"}
+	},
+
+	"charp<-string":{
+		"args":["charp", "str"],
+		"vars":{"v1-0":"str-ptr"}
+	},
+
+	"copy-charp<-charp":{
+		"args":["dst", "src"]
+	},
+
+	"cat-string<-string":{
+		"args":["a", "b"],
+		"vars":{"v1-0":"a-ptr", "a1-1":"b-ptr"}
+	},
+
+	"catn-string<-charp":{
+		"args":["a", "b", "len"],
+		"vars":{"v1-0":"a-ptr", "a3-2":"i"}
+	},
+
+	"cat-string<-string_to_charp":{
+		"args":["a", "b", "end-ptr"],
+		"vars":{"v1-0":"b-ptr", "v0-0":"a-ptr"}
+	},
+
+	"append-character-to-string":{
+		"args":["str", "char"],
+		"vars":{"v1-0":"str-ptr"}
+	},
+
+	"charp-basename":{
+		"args":["charp"],
+		"vars":{"v1-0":"ptr"}
+	},
+
+	"string<?":{
+		"args":["a", "b"],
+		"vars":{"s4-1":"len", "v1-4":"i"}
+	},
+
+	"string>?":{
+		"args":["a", "b"],
+		"vars":{"s4-1":"len", "v1-4":"i"}
+	},
+	"string<=?":{
+		"args":["a", "b"],
+		"vars":{"s4-1":"len", "v1-4":"i"}
+	},
+	"string>=?":{
+		"args":["a", "b"],
+		"vars":{"s4-1":"len", "v1-4":"i"}
+	},
+	"string-cat-to-last-char":{
+		"args":["base-str", "append-str", "char"],
+		"vars":{"s4-0":"end-of-append", "v1-0":"location-of-char"}
+	},
+	"string-suck-up!":{
+		"args":["str", "location"],
+		"vars":{"v1-2":"str-ptr"}
+	},
+	"string-strip-trailing-whitespace!":{
+		"args":["str"],
+		"vars":{"v1-6":"ptr"}
+	},
+
+	"string-get-arg!!":{
+		"args":["a-str", "arg"],
+		"vars":{"s4-0":"arg-word-start", "s4-1":"arg-end", "v1-3":"arg-start"}
+	},
+
+	"string->int":{
+		"args":["str"],
+		"vars":{"a0-1":"str-ptr", "v0-0":"result",
+		"a0-2":"next-char-1","a0-3":"next-char-2"}
+	},
+
+	"string-get-flag!!":{
+		"args":["result", "in", "first-flag", "second-flag"]
+	},
+
+	"(method 0 state)":{
+		"args":["allocation", "type-to-make", "name", "code", "trans", "enter", "exit", "event"],
+		"vars":{"v0-0":"obj"}
 	}
 
 

decompiler/util/DecompilerTypeSystem.cpp

@@ -277,7 +277,13 @@ TP_Type DecompilerTypeSystem::tp_lca(const TP_Type& existing,
         *changed = true;
         return TP_Type::make_from_ts("int");
 
-      case TP_Type::Kind::METHOD:
+      case TP_Type::Kind::VIRTUAL_METHOD:
+        // never allow this to remain method
+        *changed = true;
+        return TP_Type::make_from_ts(
+            ts.lowest_common_ancestor(existing.typespec(), add.typespec()));
+
+      case TP_Type::Kind::NON_VIRTUAL_METHOD:
         // never allow this to remain method
         *changed = true;
         return TP_Type::make_from_ts(

decompiler/util/TP_Type.cpp

@@ -55,7 +55,9 @@ std::string TP_Type::print() const {
       return fmt::format("<integer {} + ({} x {})>", m_int, m_extra_multiplier, m_ts.print());
     case Kind::DYNAMIC_METHOD_ACCESS:
       return fmt::format("<dynamic-method-access>");
-    case Kind::METHOD:
+    case Kind::VIRTUAL_METHOD:
+      return fmt::format("<vmethod {}>", m_ts.print());
+    case Kind::NON_VIRTUAL_METHOD:
       return fmt::format("<method {}>", m_ts.print());
     case Kind::INVALID:
     default:
@@ -75,7 +77,9 @@ bool TP_Type::operator==(const TP_Type& other) const {
       return m_ts == other.m_ts;
     case Kind::TYPE_OF_TYPE_NO_VIRTUAL:
       return m_ts == other.m_ts;
-    case Kind::METHOD:
+    case Kind::VIRTUAL_METHOD:
+      return m_ts == other.m_ts;
+    case Kind::NON_VIRTUAL_METHOD:
       return m_ts == other.m_ts;
     case Kind::FALSE_AS_NULL:
       return true;
@@ -144,7 +148,9 @@ TypeSpec TP_Type::typespec() const {
       return TypeSpec("object");
     case Kind::FORMAT_STRING:
       return TypeSpec("string");
-    case Kind::METHOD:
+    case Kind::VIRTUAL_METHOD:
+      return m_ts;
+    case Kind::NON_VIRTUAL_METHOD:
       return m_ts;
     case Kind::INVALID:
     default:

decompiler/util/TP_Type.h

@@ -29,7 +29,8 @@ class TP_Type {
     INTEGER_CONSTANT_PLUS_VAR,  // constant + variable. for dynamic addr of
     INTEGER_CONSTANT_PLUS_VAR_MULT,  // like var + 100 + 12 * var2
     DYNAMIC_METHOD_ACCESS,           // partial access into a
-    METHOD,
+    VIRTUAL_METHOD,
+    NON_VIRTUAL_METHOD,
     INVALID
   } kind = Kind::UNINITIALIZED;
   TP_Type() = default;
@@ -75,9 +76,16 @@ class TP_Type {
 
   static TP_Type make_from_ts(const std::string& ts) { return make_from_ts(TypeSpec(ts)); }
 
-  static TP_Type make_method(const TypeSpec& method_type) {
+  static TP_Type make_virtual_method(const TypeSpec& method_type) {
     TP_Type result;
-    result.kind = Kind::METHOD;
+    result.kind = Kind::VIRTUAL_METHOD;
+    result.m_ts = method_type;
+    return result;
+  }
+
+  static TP_Type make_non_virtual_method(const TypeSpec& method_type) {
+    TP_Type result;
+    result.kind = Kind::NON_VIRTUAL_METHOD;
     result.m_ts = method_type;
     return result;
   }

doc/code_status.md

@@ -1,81 +1,29 @@
-## gcommon.gc
-Missing stuff.
+# KERNEL
 
-## gstring-h.gc
-Empty file.
+## `gcommon`: **Done**
+- `vec4s` print/inpsect unimplemented (believed not working in GOAL either)
+- `array`'s `print`/`inspect` will not work on `uint128` or `int128`. These are believed to be unused, and also don't work in GOAL.
+- `quad-copy!` is an optimized assembly memory copy that was rewritten. It should have identical behavior, but may be slow. In the future, we could improve the performance if it's used a lot.
+- `valid?` uses some inline assembly to check if a pointer is inside the symbol table, rewritten.
+- Lots of important memory constants should be defined here.
 
-## gkernel-h.gc
-Likely missing some macros.  Missing `handle`, a child type of integer.
+## `gstring-h`: **Done**
+- This file generates no code.
 
-## gkernel.gc
-Missing lots of stuff. Will need x86-64 inline assembly and some tweaking for x86.
+## `gkernel-h`: **Done**
+- The types `cpu-thread` and `catch-frame` have a slightly different layout in OpenGOAL to back up x86-64 registers
 
-## pskernel.gc
-Possibly can be entirely left out. Seems to be mostly unused, or only used for PS2 debugging?
+## `gkernel`:
+- In progress
 
-## gstring.gc
-Missing lots
+## `pskernel`: **Done**
+- Unimplemented in OpenGOAL. Seems to be debugging hooks into the PS2's kernel. Error strings indicate that there should have been a second related file included that actually contained the debugging handlers, but this file is not present.
 
-## dgo-h.gc
-Done!
+## `gstring`: **Done**
+- `string->int` doesn't handle negative numbers correctly. This appears to be a bug in the original version.
 
-## gstate.gc
-Not started, probably needs state support in the compiler
+## `dgo-h`: **Done**
+- Just type definitions. These don't seem to match the version of DGO files found in the game, so maybe this is outdated? Also GOAL never sees DGOs, they are always processed on the IOP.
 
-## types.gc
-Needs child types of integer
-
-## vu-macros.gc
-Empty.
-
-# Math Section
-
-## math.gc
-Has a unit test for a lot of functions.
-rand-vu-init, rand-vu, rand-vu-nostep, rand-vu-float-range, rand-vu-percent?, rand-vu-int-range, rand-vu-int-count aren't implemented
-
-rand-uint31-gen might be wrong.
-
-## vector-h.gc
-Partially done
-
-## gravity-h.gc
-Empty file
-
-## bounding-box-h.gc
-Just types. Done!
-
-## matrix-h.gc
-Types and one function. Done, but the matrix-copy! function isn't that efficient.
-
-## quaternion-h.gc
-Done!
-
-## euler-h.gc
-Needs static arrays
-
-## transform-h.gc
-Done!
-
-## geometry-h.gc
-Done!
-
-## trigonometry-h.gc
-Empty File.
-
-## transformq-h.gc
-Not done. 
-
-## bounding-box.gc
-
-## matrix.gc
-
-## transform.gc
-
-## quaternion.gc
-
-## euler.gc
-
-## geometry.gc
-
-## trigonometry.gc
+## `gstate`:
+- Doing a `go` from a non-main thread of the process that is changing state is implemented a tiny bit differently. I don't think it should matter.

game/kernel/kscheme.cpp

@@ -21,6 +21,7 @@
 #include "common/versions.h"
 #include "common/goal_constants.h"
 #include "common/log/log.h"
+#include "common/util/Timer.h"
 
 //! Controls link mode when EnableMethodSet = 0, MasterDebug = 1, DiskBoot = 0. Will enable a
 //! warning message if EnableMethodSet = 1
@@ -1667,6 +1668,7 @@ s32 test_function(s32 arg0, s32 arg1, s32 arg2, s32 arg3) {
  * This takes care of all initialization that isn't for the hardware itself.
  */
 s32 InitHeapAndSymbol() {
+  Timer heap_init_timer;
   // allocate memory for the symbol table
   auto symbol_table = kmalloc(kglobalheap, 0x20000, KMALLOC_MEMSET, "symbol-table").cast<u32>();
 
@@ -1959,9 +1961,11 @@ s32 InitHeapAndSymbol() {
   // set *boot-video-mode*
   intern_from_c("*boot-video-mode*")->value = 0;
 
+  lg::info("Initialized GOAL heap in {:.2} ms", heap_init_timer.getMs());
   // load the kernel!
   // todo, remove MasterUseKernel
   if (MasterUseKernel) {
+    Timer kernel_load_timer;
     method_set_symbol->value++;
     load_and_link_dgo_from_c("kernel", kglobalheap,
                              LINK_FLAG_OUTPUT_LOAD | LINK_FLAG_EXECUTE | LINK_FLAG_PRINT_LOGIN,
@@ -1979,8 +1983,8 @@ s32 InitHeapAndSymbol() {
           (kernel_version >> 3) & 0xffff);
       return -1;
     } else {
-      lg::info("Got correct kernel version {}.{}", kernel_version >> 0x13,
-               (kernel_version >> 3) & 0xffff);
+      lg::info("Got correct kernel version {}.{}, loaded in {:.2} ms", kernel_version >> 0x13,
+               (kernel_version >> 3) & 0xffff, kernel_load_timer.getMs());
     }
   }
 

goal_src/goos-lib.gs

@@ -96,7 +96,12 @@
       )
   )
 
-
+(desfun repeated-list (obj count)
+  (if (= 0 count)
+    '()
+    (cons obj (repeated-list obj (- count 1)))
+    )
+  )
 
 (defsmacro with-gensyms (names &rest body)
   `(let

goal_src/kernel/gcommon.gc

@@ -20,6 +20,23 @@
 (defconstant RELOC_METHOD_ID 7) ;; or login?
 (defconstant MEM_USAGE_METHOD_ID 8)
 
+;; distance from a symbol pointer to a (pointer string)
+;; this relies on the memory layout of the symbol table
+;; this must match SYM_INFO_OFFSET in goal_constants.h + offset of the str field in struct SymUpper.
+(defconstant SYM_TO_STRING_OFFSET 65336)
+
+;; pointers larger than this are invalid by valid?
+(defconstant END_OF_MEMORY #x8000000)
+
+;; boxed object offset (16-byte alignement offsets)
+(defconstant BINTEGER_OFFSET 0)
+(defconstant PAIR_OFFSET 2)
+(defconstant BASIC_OFFSET 4)
+
+(defmacro symbol-to-string (sym)
+  ;; "Convert a symbol to a goal string."
+  `(-> (the-as (pointer string) (+ SYM_TO_STRING_OFFSET (the-as int ,sym))))
+  )
 
 ;; forward declarations.
 (define-extern name= (function basic basic symbol))
@@ -1114,15 +1131,15 @@
   (local-vars (current-qword int))
   (set! current-qword 0)
   (while (< current-qword (sar word-count 2))
-   (format 0 "~X: ~X ~X ~X ~X~%"
-    (+ (+ (shl (shl current-qword 2) 2) 0) (the-as int data))
-    (-> data (shl current-qword 2))
-    (-> data (+ (shl current-qword 2) 1))
-    (-> data (+ (shl current-qword 2) 2))
-    (-> data (+ (shl current-qword 2) 3))
+    (format 0 "~X: ~X ~X ~X ~X~%"
+            (+ (+ (shl (shl current-qword 2) 2) 0) (the-as int data))
+            (-> data (shl current-qword 2))
+            (-> data (+ (shl current-qword 2) 1))
+            (-> data (+ (shl current-qword 2) 2))
+            (-> data (+ (shl current-qword 2) 3))
+            )
+    (set! current-qword (+ current-qword 1))
     )
-   (set! current-qword (+ current-qword 1))
-   )
   '#f
   )
 
@@ -1138,9 +1155,9 @@
         (format '#t "    ")
         (format '#t "|   ")
         )
-   (set! bits (shr bits 1))
-   (set! i (+ i 1))
-   )
+    (set! bits (shr bits 1))
+    (set! i (+ i 1))
+    )
   '#f
   )
 
@@ -1150,6 +1167,8 @@
   0
   )
 
+
+;; these are not quite right, but it's close enough.
 (defmacro start-of-symbol-table ()
   `(rlet ((st :reg r15 :reset-here #t :type uint))
          (the uint (- st 32768))
@@ -1189,7 +1208,7 @@
 
   ;; first, check if we are even in valid memory. This is the start of the symbol table to the end of RAM.
   (set! in-goal-mem (and (>= (the-as uint obj) (start-of-symbol-table))
-                         (< (the-as uint obj) #x8000000)
+                         (< (the-as uint obj) END_OF_MEMORY)
                          )
         )
   (cond
@@ -1242,7 +1261,7 @@
        ((= expected-type pair)
         ;; pair alignment is 8 bytes + 2.
         (cond
-          ((!= (logand (the-as int obj) 7) 2)
+          ((!= (logand (the-as int obj) 7) PAIR_OFFSET)
            (if name
                (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" obj name expected-type)
                )
@@ -1273,7 +1292,7 @@
           )
         )
        ;; now we assume desired type is a basic.
-       ((!= (logand (the-as int obj) 7) 4)
+       ((!= (logand (the-as int obj) 7) BASIC_OFFSET)
         (if name
             (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" obj name expected-type)
             )
@@ -1299,13 +1318,11 @@
         ;; otherwise... we want to check and see if the type is actually a type.
         ;; we use valid? to do this check.
         ;; avoid infinite recursion by skipping this check if the expected-type is type.
-        (set! v1-33 (and (!= expected-type type)
-                         (not (valid? (rtype-of obj) type '#f '#t 0)
-                              )
-                         )
-              )
+
         (cond
-          (v1-33
+          ((and (!= expected-type type)
+                (not (valid? (rtype-of obj) type '#f '#t 0))
+                )
            (if name
                ;; note: print the invalid type as an address in case it's unprintable.
                (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"

goal_src/kernel/gkernel-h.gc

@@ -141,6 +141,7 @@
 (declare-type state basic)
 (declare-type cpu-thread basic)
 (declare-type dead-pool basic)
+(declare-type event-message-block structure)
 
 ; DANGER - this type is created in kscheme.cpp. It has room for 12 methods and size 0x28 bytes.
 (deftype thread (basic)
@@ -233,9 +234,9 @@
    (state state :offset-assert #x38)
    (trans-hook function :offset-assert #x3c)
    (post-hook function :offset-assert #x40)
-   (event-hook (function stack-frame (function object) function state object) :offset-assert #x44)
+   (event-hook (function basic int basic event-message-block object) :offset-assert #x44)
    (allocated-length int32 :offset-assert #x48)
-   (next-state basic :offset-assert #x4c)
+   (next-state state :offset-assert #x4c)
    (heap-base pointer :offset-assert #x50)
    (heap-top pointer :offset-assert #x54)
    (heap-cur pointer :offset-assert #x58)
@@ -432,12 +433,13 @@
    (trans (function object)  :offset-assert 20)
    (post  function  :offset-assert 24)
    (enter (function object object object object object object object)  :offset-assert 28)
-   (event basic     :offset-assert 32)
+   (event (function basic int basic event-message-block object)     :offset-assert 32)
    )
   (:methods
-   (new ((allocation symbol) (type-to-make type) (name basic) (code function) 
-         (trans function) (enter function) (exit (function object)) (event function)) _type_ 0)
-   )
+    (new ((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))) _type_ 0)
+    )
   :method-count-assert 9
   :size-assert         #x24
   :flag-assert         #x900000024
@@ -505,9 +507,14 @@
   `(!= 0 (logand ,mask (process-mask ,enum-value)))
   )
 
-(defmacro process-mask-set! (mask enum-value)
+(defmacro process-mask-set! (mask &rest enum-value)
   ;; sets the given bits in the process mask (with or)
-  `(set! ,mask (logior ,mask (process-mask ,enum-value)))
+  `(set! ,mask (logior ,mask (process-mask ,@enum-value)))
+  )
+
+(defmacro process-mask-clear! (mask &rest enum-value)
+  ;; sets the given bits in the process mask (with or)
+  `(set! ,mask (logand ,mask (lognot (process-mask ,@enum-value))))
   )
 
 (defmacro suspend ()
@@ -531,3 +538,8 @@
          (deactivate pp)
          )
   )
+
+(defmacro with-pp (&rest body)
+  `(rlet ((pp :reg r13 :reset-here #t :type process))
+         ,@body)
+  )

goal_src/kernel/gkernel.gc

@@ -641,9 +641,7 @@
 (defmethod thread-suspend cpu-thread ((unused cpu-thread))
   "Suspend the thread and return to the kernel."
   
-  (declare (asm-func none)
-           ;(print-asm)
-           )
+  (declare (asm-func none))
   
   ;; we begin this function with the thread object in pp.
   ;; not sure why we do this, maybe at one point suspending didn't clobber
@@ -656,71 +654,99 @@
          (s1 :reg rbp :type uint)
          (s2 :reg r10 :type uint)
          (s3 :reg r11 :type uint)
-         (s4 :reg r12 :type uint))
+         (s4 :reg r12 :type uint)
+         
+         (xmm8 :reg xmm8 :class fpr)
+         (xmm9 :reg xmm9 :class fpr)
+         (xmm10 :reg xmm10 :class fpr)
+         (xmm11 :reg xmm11 :class fpr)
+         (xmm12 :reg xmm12 :class fpr)
+         (xmm13 :reg xmm13 :class fpr)
+         (xmm14 :reg xmm14 :class fpr)
+         (xmm15 :reg xmm15 :class fpr)
+         )
         
-        ;; get the return address pushed by "call" in the suspend.
-        (.pop temp)
-        ;; convert to a GOAL address
-        (.sub temp off)
-        ;; store return address in thread
-        (set! (-> obj pc) (the pointer temp))
+    ;; get the return address pushed by "call" in the suspend.
+    (.pop temp)
+    ;; convert to a GOAL address
+    (.sub temp off)
+    ;; store return address in thread
+    (set! (-> obj pc) (the pointer temp))
         
-        ;; convert our stack pointer to a GOAL address
-        (.sub sp off)
-        ;; store in thread.
-        (set! (-> obj sp) (the pointer sp))
+    ;; convert our stack pointer to a GOAL address
+    (.sub sp off)
+    ;; store in thread.
+    (set! (-> obj sp) (the pointer sp))
         
-        ;; back up registers
-        (.mov :color #f temp s0)
-        (set! (-> obj rreg 0) temp)
-        (.mov :color #f temp s1)
-        (set! (-> obj rreg 1) temp)
-        (.mov :color #f temp s2)
-        (set! (-> obj rreg 2) temp)
-        (.mov :color #f temp s3)
-        (set! (-> obj rreg 3) temp)
-        (.mov :color #f temp s4)
-        (set! (-> obj rreg 4) temp)
+    ;; back up registers
+    (.mov :color #f temp s0)
+    (set! (-> obj rreg 0) temp)
+    (.mov :color #f temp s1)
+    (set! (-> obj rreg 1) temp)
+    (.mov :color #f temp s2)
+    (set! (-> obj rreg 2) temp)
+    (.mov :color #f temp s3)
+    (set! (-> obj rreg 3) temp)
+    (.mov :color #f temp s4)
+    (set! (-> obj rreg 4) temp)
         
-        ;; todo, back up fprs
+    ;; back up fprs
+    (.mov :color #f temp xmm8)
+    (set! (-> obj freg 0) (the-as float temp))
+    (.mov :color #f temp xmm9)
+    (set! (-> obj freg 1) (the-as float temp))
+    (.mov :color #f temp xmm10)
+    (set! (-> obj freg 2) (the-as float temp))
+    (.mov :color #f temp xmm11)
+    (set! (-> obj freg 3) (the-as float temp))
+    (.mov :color #f temp xmm12)
+    (set! (-> obj freg 4) (the-as float temp))
+    (.mov :color #f temp xmm13)
+    (set! (-> obj freg 5) (the-as float temp))
+    (.mov :color #f temp xmm14)
+    (set! (-> obj freg 6) (the-as float temp))
+    (.mov :color #f temp xmm15)
+    (set! (-> obj freg 7) (the-as float temp))
+
         
-        ;; get our process
-        (let ((proc (-> obj process)))
-          (when (> (process-stack-used proc) (-> obj stack-size))
-            (break) ;; too much stack has been used and we can't suspend!
-            )
-          
-          ;; mark the process as suspended and copy the stack
-          (set! (-> proc status) 'suspended)
-          (let ((cur (the (pointer uint64) (-> obj stack-top)))
-                (save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
-                )
-            (while (> (the int cur) (the int sp))
-              (set! cur (the (pointer uint64) (&- cur 8)))
-              (set! save (the (pointer uint64) (&- save 8)))
-              (set! (-> save) (-> cur))
-              )
-            )
-          )
         
-        ;; actually setting pp to 0
-        (set! obj (the cpu-thread 0))
-        
-        ;; get the kernel stack pointer as a GOAL pointer
-        (.load-sym :sext #f sp *kernel-sp*)
-        ;; convert it back to a real pointer
-        (.add sp off)
-        
-        ;; restore saved registers...
-        ;; without coloring system because this is "cheating".
-        (.pop :color #f s4)
-        (.pop :color #f s3)
-        (.pop :color #f s2)
-        (.pop :color #f s1)
-        (.pop :color #f s0)
-        ;; return to the kernel function that called the user code
-        (.ret)
+    ;; get our process
+    (let ((proc (-> obj process)))
+      (when (> (process-stack-used proc) (-> obj stack-size))
+        (break) ;; too much stack has been used and we can't suspend!
         )
+          
+      ;; mark the process as suspended and copy the stack
+      (set! (-> proc status) 'suspended)
+      (let ((cur (the (pointer uint64) (-> obj stack-top)))
+            (save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
+            )
+        (while (> (the int cur) (the int sp))
+          (set! cur (the (pointer uint64) (&- cur 8)))
+          (set! save (the (pointer uint64) (&- save 8)))
+          (set! (-> save) (-> cur))
+          )
+        )
+      )
+        
+    ;; actually setting pp to 0
+    (set! obj (the cpu-thread 0))
+        
+    ;; get the kernel stack pointer as a GOAL pointer
+    (.load-sym :sext #f sp *kernel-sp*)
+    ;; convert it back to a real pointer
+    (.add sp off)
+        
+    ;; restore saved registers...
+    ;; without coloring system because this is "cheating".
+    (.pop :color #f s4)
+    (.pop :color #f s3)
+    (.pop :color #f s2)
+    (.pop :color #f s1)
+    (.pop :color #f s0)
+    ;; return to the kernel function that called the user code
+    (.ret)
+    )
   (none)
   )
 
@@ -730,7 +756,7 @@
    This is also used to start a thread initialized with set-to-run.
    As a result of MIPS/x86 differences, there is a hack for this."
   (declare (asm-func none)
-           ;(print-asm)
+           ;;(print-asm)
            )
   
   (rlet ((obj :reg r13 :type cpu-thread)
@@ -744,81 +770,106 @@
          (s4 :reg r12 :type uint)
          (a4 :reg r8 :type uint)
          (a5 :reg r9 :type uint)
+
+         (temp-float :reg xmm0 :class fpr)
+         (xmm8 :reg xmm8 :class fpr)
+         (xmm9 :reg xmm9 :class fpr)
+         (xmm10 :reg xmm10 :class fpr)
+         (xmm11 :reg xmm11 :class fpr)
+         (xmm12 :reg xmm12 :class fpr)
+         (xmm13 :reg xmm13 :class fpr)
+         (xmm14 :reg xmm14 :class fpr)
+         (xmm15 :reg xmm15 :class fpr)
          ) 
         
-        ;; save the current kernel regs
-        (.push :color #f s0)
-        (.push :color #f s1)
-        (.push :color #f s2)
-        (.push :color #f s3)
-        (.push :color #f s4)
+    ;; save the current kernel regs
+    (.push :color #f s0)
+    (.push :color #f s1)
+    (.push :color #f s2)
+    (.push :color #f s3)
+    (.push :color #f s4)
         
-        ;; make rsp a GOAL pointer
-        (.sub sp off)
-        ;; and store it
-        (set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
+    ;; make rsp a GOAL pointer
+    (.sub sp off)
+    ;; and store it
+    (set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
         
-        ;; temp, stash thread in process-pointer
-        (set! obj thread-to-resume)
+    ;; temp, stash thread in process-pointer
+    (set! obj thread-to-resume)
         
-        ;; set stack pointer for the thread. leave it as a GOAL pointer for now..
-        (set! sp (the uint (-> obj sp)))
+    ;; set stack pointer for the thread. leave it as a GOAL pointer for now..
+    (set! sp (the uint (-> obj sp)))
         
-        ;; restore the stack (sp is a GOAL pointer)
-        (let ((cur (the (pointer uint64) (-> obj stack-top)))
-              (restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
-              )
-          (while (> (the int cur) (the int sp))
-            (set! cur (the (pointer uint64) (&- cur 8)))
-            (set! restore (the (pointer uint64) (&- restore 8)))
-            (set! (-> cur) (-> restore))
-            )
+    ;; restore the stack (sp is a GOAL pointer)
+    (let ((cur (the (pointer uint64) (-> obj stack-top)))
+          (restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
           )
-        
-        ;; offset sp after we're done using it as a GOAL pointer.
-        (.add sp off)
-        
-        ;; setup process
-        (set! (-> (-> obj process) top-thread) obj)
-        (set! (-> (-> obj process) status) 'running)
-        
-        ;; restore reg
-        (set! temp (-> obj rreg 0))
-        (.mov :color #f s0 temp)
-        (set! temp (-> obj rreg 1))
-        (.mov :color #f s1 temp)
-        (set! temp (-> obj rreg 2))
-        (.mov :color #f s2 temp)
-        (set! temp (-> obj rreg 3))
-        (.mov :color #f s3 temp)
-        (set! temp (-> obj rreg 4))
-        (.mov :color #f s4 temp)
-        ;; todo restore fpr.
-        
-        ;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
-        ;; expects to receive 7 values from the cpu thread's rregs.
-        ;; usually rreg holds saved registers, but on the first resume after
-        ;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
-        
-        ;; We only have 5 saved regs, so we need to cheat and directly pass
-        ;; two values in other registers
-        ;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
-        ;; In the case where we are doing a normal resume, the 
-        ;; compiler should assume that these registers are overwritten anyway.
-        (set! temp (-> obj rreg 5))
-        (.mov a4 temp)
-        (set! temp (-> obj rreg 6))
-        (.mov a5 temp)
-        
-        ;; get the resume address
-        (set! temp (the uint (-> obj pc)))
-        (.add temp off)
-        
-        ;; setup the process
-        (set! obj (the cpu-thread (-> obj process)))
-        ;; resume!
-        (.jr temp)
+      (while (> (the int cur) (the int sp))
+        (set! cur (the (pointer uint64) (&- cur 8)))
+        (set! restore (the (pointer uint64) (&- restore 8)))
+        (set! (-> cur) (-> restore))
         )
+      )
+        
+    ;; offset sp after we're done using it as a GOAL pointer.
+    (.add sp off)
+        
+    ;; setup process
+    (set! (-> (-> obj process) top-thread) obj)
+    (set! (-> (-> obj process) status) 'running)
+        
+    ;; restore reg
+    (set! temp (-> obj rreg 0))
+    (.mov :color #f s0 temp)
+    (set! temp (-> obj rreg 1))
+    (.mov :color #f s1 temp)
+    (set! temp (-> obj rreg 2))
+    (.mov :color #f s2 temp)
+    (set! temp (-> obj rreg 3))
+    (.mov :color #f s3 temp)
+    (set! temp (-> obj rreg 4))
+    (.mov :color #f s4 temp)
+    (set! temp-float (-> obj freg 0))
+    (.mov :color #f xmm8 temp-float)
+    (set! temp-float (-> obj freg 1))
+    (.mov :color #f xmm9 temp-float)
+    (set! temp-float (-> obj freg 2))
+    (.mov :color #f xmm10 temp-float)
+    (set! temp-float (-> obj freg 3))
+    (.mov :color #f xmm11 temp-float)
+    (set! temp-float (-> obj freg 4))
+    (.mov :color #f xmm12 temp-float)
+    (set! temp-float (-> obj freg 5))
+    (.mov :color #f xmm13 temp-float)
+    (set! temp-float (-> obj freg 6))
+    (.mov :color #f xmm14 temp-float)
+    (set! temp-float (-> obj freg 7))
+    (.mov :color #f xmm15 temp-float)
+    
+    ;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
+    ;; expects to receive 7 values from the cpu thread's rregs.
+    ;; usually rreg holds saved registers, but on the first resume after
+    ;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
+        
+    ;; We only have 5 saved regs, so we need to cheat and directly pass
+    ;; two values in other registers
+    ;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
+    ;; In the case where we are doing a normal resume, the 
+    ;; compiler should assume that these registers are overwritten anyway.
+    (set! temp (-> obj rreg 5))
+    (.mov a4 temp)
+    (set! temp (-> obj rreg 6))
+    (.mov a5 temp)
+        
+    ;; get the resume address
+    (set! temp (the uint (-> obj pc)))
+    (.add temp off)
+        
+    ;; setup the process
+    (set! obj (the cpu-thread (-> obj process)))
+    ;; resume!
+    (.jr temp)
+    )
   (none)
   )
 
@@ -903,10 +954,14 @@
 ;; Process Dead Pool Heap
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
-; these processes start out with a lot of memory, then shrink their heap (compact) to the size
-; they actually need.  To avoid heap fragmentation, the dead-pool-heap system will relocate
-; processes. This requires that you implement the relocate method on your process.
+;; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
+;; these processes start out with a lot of memory, then shrink their heap (compact) to the size
+;; they actually need.  To avoid heap fragmentation, the dead-pool-heap system will relocate
+;; processes. This requires that you implement the relocate method on your process.
+
+;; DANGER: the dead pool heap is _not_ a proper process tree. Do not attempt to treat it like on.
+;;  If you get-process, you should immediately activate it. The activate method will (change-parent)
+;;  and this will get stuck in an endless loop if you do it on a process that wasn't the most recent one.
 
 (define-extern *null-process* process)
 
@@ -1612,7 +1667,6 @@
     (lambda ((obj process))
       ;(format 0 "Call to dispatcher lambda!~%")
       (let ((context *kernel-context*))
-        
         (cond
           ((or (eq? (-> obj status) 'waiting-to-run)
                (eq? (-> obj status) 'suspended))
@@ -1658,8 +1712,10 @@
            (if (process-mask? (-> obj mask) sleep-code)
                ;; we're sleeping. Move us to suspended, in case we were in waiting to run.
                (set! (-> obj status) 'suspended)
+
                ;; not sleeping. call resume hook
                ((-> obj main-thread resume-hook) (-> obj main-thread))
+               
                )
            ;; check for deadness
            (cond
@@ -1763,7 +1819,6 @@
   The allocation must be an address.
   Unlike the original, this only works on the first six parameters, but I think this doesn't matter."
   (declare (asm-func object)
-           ;(print-asm)
            (allow-saved-regs) ;; very dangerous!
            )
   
@@ -1776,79 +1831,102 @@
          (s2 :reg r10 :type (pointer uint64))
          (s3 :reg r11 :type uint)
          (s4 :reg r12 :type uint)
+
+         (xmm8 :reg xmm8 :class fpr)
+         (xmm9 :reg xmm9 :class fpr)
+         (xmm10 :reg xmm10 :class fpr)
+         (xmm11 :reg xmm11 :class fpr)
+         (xmm12 :reg xmm12 :class fpr)
+         (xmm13 :reg xmm13 :class fpr)
+         (xmm14 :reg xmm14 :class fpr)
+         (xmm15 :reg xmm15 :class fpr)
          ) 
         
-        ;; we treat the allocation as an address.
-        (let ((obj (the catch-frame (&+ allocation *gtype-basic-offset*))))
-          ;; setup catch frame
-          (set! (-> obj type) type-to-make)
-          (set! (-> obj name) name)
-          ;; get the return address (the compiler won't touch the stack because we're an asm-func)
-          (.pop temp)
-          (.push temp)
-          ;; make it a GOAL address so it fits in 32 bitys
-          (.sub temp off)
-          ;; store it
-          (set! (-> obj ra) (the int temp))
+    ;; we treat the allocation as an address.
+    (let ((obj (the catch-frame (&+ allocation *gtype-basic-offset*))))
+      ;; setup catch frame
+      (set! (-> obj type) type-to-make)
+      (set! (-> obj name) name)
+      ;; get the return address (the compiler won't touch the stack because we're an asm-func)
+      (.pop temp)
+      (.push temp)
+      ;; make it a GOAL address so it fits in 32 bitys
+      (.sub temp off)
+      ;; store it
+      (set! (-> obj ra) (the int temp))
           
-          ;; todo, do we need a stack offset here?
-          ;; remember the stack pointer
-          (set! temp sp)
-          (.sub temp off)
-          (set! (-> obj sp) (the int temp))
+      ;; todo, do we need a stack offset here?
+      ;; remember the stack pointer
+      (set! temp sp)
+      (.sub temp off)
+      (set! (-> obj sp) (the int temp))
           
-          ;; back up registers we care about
-          (.mov :color #f temp s0)
-          (set-u128-as-u64! (-> obj rreg 0) temp)
-          (.mov :color #f temp s1)
-          (set-u128-as-u64! (-> obj rreg 1) temp)
-          (.mov :color #f temp s2)
-          (set-u128-as-u64! (-> obj rreg 2) temp)
-          (.mov :color #f temp s3)
-          (set-u128-as-u64! (-> obj rreg 3) temp)
-          (.mov :color #f temp s4)
-          (set-u128-as-u64! (-> obj rreg 4) temp)
-          ;; todo save fprs
+      ;; back up registers we care about
+      (.mov :color #f temp s0)
+      (set-u128-as-u64! (-> obj rreg 0) temp)
+      (.mov :color #f temp s1)
+      (set-u128-as-u64! (-> obj rreg 1) temp)
+      (.mov :color #f temp s2)
+      (set-u128-as-u64! (-> obj rreg 2) temp)
+      (.mov :color #f temp s3)
+      (set-u128-as-u64! (-> obj rreg 3) temp)
+      (.mov :color #f temp s4)
+      (set-u128-as-u64! (-> obj rreg 4) temp)
+
+      (.mov :color #f temp xmm8)
+      (set! (-> obj freg 0) (the-as float temp))
+      (.mov :color #f temp xmm9)
+      (set! (-> obj freg 1) (the-as float temp))
+      (.mov :color #f temp xmm10)
+      (set! (-> obj freg 2) (the-as float temp))
+      (.mov :color #f temp xmm11)
+      (set! (-> obj freg 3) (the-as float temp))
+      (.mov :color #f temp xmm12)
+      (set! (-> obj freg 4) (the-as float temp))
+      (.mov :color #f temp xmm13)
+      (set! (-> obj freg 5) (the-as float temp))
+      (.mov :color #f temp xmm14)
+      (set! (-> obj freg 6) (the-as float temp))
+      (.mov :color #f temp xmm15)
+      (set! (-> obj freg 7) (the-as float temp))
           
-          ;; push this stack frame
-          (set! (-> obj next) (-> pp stack-frame-top))
-          (set! (-> pp stack-frame-top) obj)
+      ;; push this stack frame
+      (set! (-> obj next) (-> pp stack-frame-top))
+      (set! (-> pp stack-frame-top) obj)
           
-          ;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
-          (.push :color #f s3)
-          (.push :color #f s2)
-          (.push :color #f s2)
-          (set! s3 (the uint func))
-          (set! s2 param-block)
+      ;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
+      (.push :color #f s3)
+      (.push :color #f s2)
+      (.push :color #f s2)
+      (set! s3 (the uint func))
+      (set! s2 param-block)
           
-          ;; todo - are we aligned correctly here?
-          (let ((ret ((the-super-u64-fucntion s3)
-                      (-> s2 0)
-                      (-> s2 1)
-                      (-> s2 2)
-                      (-> s2 3)
-                      (-> s2 4)
-                      (-> s2 5)
-                      ))
-                )
-            (.pop :color #f s2)
-            (.pop :color #f s2)
-            (.pop :color #f s3)
-            (set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
-            (.ret)
-            (the object ret)
+      ;; todo - are we aligned correctly here?
+      (let ((ret ((the-super-u64-fucntion s3)
+                  (-> s2 0)
+                  (-> s2 1)
+                  (-> s2 2)
+                  (-> s2 3)
+                  (-> s2 4)
+                  (-> s2 5)
+                  ))
             )
-          )
+        (.pop :color #f s2)
+        (.pop :color #f s2)
+        (.pop :color #f s3)
+        (set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
+        (.ret)
+        (the object ret)
         )
+      )
+    )
   )
 
 
 (defun throw-dispatch ((obj catch-frame) value)
   "Throw the given value to the catch frame.
   Only can throw a 64-bit value. The original could throw 128 bits."
-  (declare (asm-func none)
-           ;(print-asm)
-           )
+  (declare (asm-func none))
   
   (rlet ((pp :reg r13 :type process)
          (temp :reg rax :type uint)
@@ -1859,38 +1937,64 @@
          (s2 :reg r10 :type (pointer uint64))
          (s3 :reg r11 :type uint)
          (s4 :reg r12 :type uint)
+
+         (temp-float :reg xmm0 :class fpr)
+         (xmm8 :reg xmm8 :class fpr)
+         (xmm9 :reg xmm9 :class fpr)
+         (xmm10 :reg xmm10 :class fpr)
+         (xmm11 :reg xmm11 :class fpr)
+         (xmm12 :reg xmm12 :class fpr)
+         (xmm13 :reg xmm13 :class fpr)
+         (xmm14 :reg xmm14 :class fpr)
+         (xmm15 :reg xmm15 :class fpr)
          )
         
-        ;; pop everything we threw past
-        (set! (-> pp stack-frame-top) (-> obj next))
+    ;; pop everything we threw past
+    (set! (-> pp stack-frame-top) (-> obj next))
         
-        ;; restore regs we care about.
-        (set-u64-from-u128! temp (-> obj rreg 0))
-        (.mov :color #f s0 temp)
-        (set-u64-from-u128! temp (-> obj rreg 1))
-        (.mov :color #f s1 temp)
-        (set-u64-from-u128! temp (-> obj rreg 2))
-        (.mov :color #f s2 temp)
-        (set-u64-from-u128! temp (-> obj rreg 3))
-        (.mov :color #f s3 temp)
-        (set-u64-from-u128! temp (-> obj rreg 4))
-        (.mov :color #f s4 temp)
-        ;; todo fpr
+    ;; restore regs we care about.
+    (set-u64-from-u128! temp (-> obj rreg 0))
+    (.mov :color #f s0 temp)
+    (set-u64-from-u128! temp (-> obj rreg 1))
+    (.mov :color #f s1 temp)
+    (set-u64-from-u128! temp (-> obj rreg 2))
+    (.mov :color #f s2 temp)
+    (set-u64-from-u128! temp (-> obj rreg 3))
+    (.mov :color #f s3 temp)
+    (set-u64-from-u128! temp (-> obj rreg 4))
+    (.mov :color #f s4 temp)
+
+    (set! temp-float (-> obj freg 0))
+    (.mov :color #f xmm8 temp-float)
+    (set! temp-float (-> obj freg 1))
+    (.mov :color #f xmm9 temp-float)
+    (set! temp-float (-> obj freg 2))
+    (.mov :color #f xmm10 temp-float)
+    (set! temp-float (-> obj freg 3))
+    (.mov :color #f xmm11 temp-float)
+    (set! temp-float (-> obj freg 4))
+    (.mov :color #f xmm12 temp-float)
+    (set! temp-float (-> obj freg 5))
+    (.mov :color #f xmm13 temp-float)
+    (set! temp-float (-> obj freg 6))
+    (.mov :color #f xmm14 temp-float)
+    (set! temp-float (-> obj freg 7))
+    (.mov :color #f xmm15 temp-float)
         
-        ;; set stack pointer
-        (set! sp (the uint (-> obj sp)))
-        (.add sp off)
+    ;; set stack pointer
+    (set! sp (the uint (-> obj sp)))
+    (.add sp off)
         
-        ;; overwrite our return address
-        (.pop temp)
-        (set! temp (the uint (-> obj ra)))
-        (.add temp off)
-        (.push temp)
+    ;; overwrite our return address
+    (.pop temp)
+    (set! temp (the uint (-> obj ra)))
+    (.add temp off)
+    (.push temp)
         
-        ;; load the return register
-        (.mov temp value)
-        (.ret)
-        )
+    ;; load the return register
+    (.mov temp value)
+    (.ret)
+    )
   )
 
 (defun throw ((name symbol) value)
@@ -2006,6 +2110,7 @@
   (let ((thread (new 'global 'cpu-thread obj 'code PROCESS_STACK_SAVE_SIZE stack-top)))
     (set! (-> obj main-thread) thread)
     )
+
   (change-parent obj dest)
   )
 

goal_src/kernel/gstate.gc

@@ -4,3 +4,349 @@
 ;; name: gstate.gc
 ;; name in dgo: gstate
 ;; dgos: KERNEL
+
+#|
+Summary of state system:
+
+A process can be put into a state, using enter-state, or the go macro.
+This will set up the process to run the appropriate handler functions defined by the state.
+The state handlers are:
+- enter : gets run before trans on the first time the state is used. Can be #f. Must return.
+- trans : gets run before code each time the code is run. Can be #f. Must return.
+- code  : main thread. Can suspend. If it returns, the process dies
+- exit  : gets run when leaving a state. must return.
+- event : not sure of the details here yet.
+
+You can "go" to another state.  This causes the current main thread execution to be abandoned.
+If the main thread has exits/protects on the stack frame, they will be run first to clean up.
+
+There are several ways to "go"
+- go during init: when a process is being initialized with run-function-in-process, you can "go".
+  this causes the run-function-in-process to return, and the next time the process is dispatched
+  it will go into the other state.  This will automatically set the process to waiting-to-run,
+  and shrink the process heap, if appropriate
+
+- go from outside the process. You can temporarily set pp to another process, and have that
+  process go to another state. The actually go will occur the next time the process is scheduled.
+
+- go from a non-main thread in the right process. You can do a go from a temporary thread, like trans or post.
+  If you do it from post, the go returns. If you do it from any other thread, the temporary thread
+  is immediately abandonded. Like the previous two, it will defer the actual go until the next time the
+  process runs.
+
+- go from the main thread of the main process. This causes the (-> pp state) to change, the stack frames
+  to be cleaned up, and the old state's exit to be called.  It will reset the stack, then run the code.
+
+|#
+
+;; fancy macro to accept variable arguments for go.
+;; (defmacro go (next-state &rest args)
+;;   (if (< 6 (length args))
+;;       (error "too many arguments to go")
+;;       (let ((zero-args (repeated-list 0 (- 6 (length args)))))
+;;         `(with-pp
+;;            (set! (-> pp next-state) ,next-state)
+;;            (enter-state ,@args ,@zero-args)
+;;            )
+;;         )
+;;       )
+;;   )
+
+;; cause the current process to change state
+(defmacro go (next-state &rest args)
+  `(with-pp
+     (set! (-> pp next-state) ,next-state)
+     ((the (function _varargs_ object) enter-state) ,@args)
+     )
+  )
+
+;; cause the given process to change state.
+(defmacro go-process (proc state &rest args)
+  `(with-pp
+     (protect (pp)
+              (set! pp ,proc)
+              (set! (-> pp next-state) ,state)
+              ((the (function _varargs_ object) enter-state) ,@args)
+              )
+     )
+  )
+
+;; run the given function in a process right now.
+;; will return to here when:
+;;  - you return
+;;  - you deactivate
+;;  - you go
+;;  - you throw to 'initialize
+(defmacro run-now-in-process (proc func &rest args)
+  `((the (function _varargs_ object) run-function-in-process)
+    ,proc ,func ,@args
+    )
+  )
+
+;; sets the main thread of the given process to run the given thing.
+;; this resets the main thread stack back to the top
+(defmacro run-next-time-in-process (proc func &rest args)
+  `((the (function _varargs_ object) set-to-run)
+    (-> ,proc main-thread) ,func ,@args
+    )
+  )
+
+;; display a listing of active processes.
+(defmacro ps (&key (detail #f))
+  `(inspect-process-tree *active-pool* 0 0 ,detail)
+  )
+
+
+;; define a state state
+(defmacro defstate (state-name
+                    &key (event #f)
+                    &key (enter #f)
+                    &key (trans #f)
+                    &key (exit #f)
+                    &key (code #f)
+                    &key (post #f)
+                      )
+  `(begin
+    (define ,state-name (new 'static 'state
+                             :name (quote ,state-name)
+                             :next #f
+                             :exit #f
+                             :code #f
+                             :trans #f
+                             :post #f
+                             :enter #f
+                             :event #f
+                             )
+      )
+    ,(if event
+         `(set! (-> ,state-name event) ,event)
+         `(none)
+         )
+    ,(if enter
+         `(set! (-> ,state-name enter) (the (function object object object object object object object) ,enter))
+         `(none)
+         )
+    ,(if trans
+         `(set! (-> ,state-name trans) ,trans)
+         `(none)
+         )
+    ,(if exit
+         `(set! (-> ,state-name exit) ,exit)
+         `(none)
+         )
+    ,(if code
+         `(set! (-> ,state-name code) ,code)
+         `(none)
+         )
+    ,(if post
+         `(set! (-> ,state-name post) ,post)
+         `(none)
+         )
+    )
+    
+  )
+  
+
+(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)))
+  "Allocate a new state. It seems like this isn't really used much and most states are
+   statically allocated and as a result don't have the constructor called."
+  (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
+    )
+  )
+
+(defun inherit-state ((child state) (parent state))
+  "Copy handler functions from parent to child"
+  (set! (-> child exit) (-> parent exit))
+  (set! (-> child code) (-> parent code))
+  (set! (-> child trans) (-> parent trans))
+  (set! (-> child post) (-> parent post))
+  (set! (-> child enter) (-> parent enter))
+  (set! (-> child event) (-> parent event))
+  child
+  )
+
+(defmethod print state ((obj state))
+  "Print a state."
+  (format '#t "#<~A ~A @ #x~X>" (-> obj type) (-> obj name) obj)
+  obj
+  )
+
+(define-extern enter-state (function object object object object object object object))
+(defun enter-state (arg0 arg1 arg2 arg3 arg4 arg5)
+  "Make the process stored in pp enter the state in pp next-state"
+  ;;(declare (print-asm))
+  (with-pp
+    ;; unsleep us
+    (process-mask-clear! (-> pp mask) sleep sleep-code)
+    ;; mark as going
+    (process-mask-set! (-> pp mask) going)
+    (cond
+      ((= (-> pp status) 'initialize)
+       ;; did a go during initialize.
+       ;; remove the old trans hook, if there was one
+       (set! (-> pp trans-hook) #f)
+       (set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
+       ;; tell the kernel that we did a go during init
+       (set! (-> pp status) 'initialize-go)
+       ;; abandon this thread, go back to what initialized us!
+       (throw 'initialize #t)
+       #t
+       )
+      ((!= (-> *kernel-context* current-process) pp)
+       ;; we aren't actually in process pp right now.
+       ;; so set us up to go in the next run
+       (let ((status-backup (-> pp status)))
+         (set! (-> pp trans-hook) #f)
+         ;; will set waiting-to-run
+         (set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
+         ;; restore the old status.
+         (set! (-> pp status) status-backup)
+         #t
+         )
+       )
+      ((= (-> pp main-thread) (-> pp top-thread))
+       ;; we are in the right process, and in the main thread!
+       ;; actually do a go!
+       (set! (-> pp state) (-> pp next-state))
+
+       ;; loop through current stack frames
+       (let ((frame (-> pp stack-frame-top)))
+         (while frame
+           (let ((typ (-> frame type)))
+             (if (or (= typ protect-frame) (= typ state))
+                 ;; if we got a protect-frame or a state, call exit handler
+                 ((-> (the protect-frame frame) exit))
+                 )
+             )
+           (set! frame (-> frame next))
+           )
+         )
+       
+       ;; done with going!
+       (process-mask-clear! (-> pp mask) going)
+
+       ;; now, update the process:
+       (let ((new-state (-> pp state)))
+         ;; event hook from the current state
+         (set! (-> pp event-hook) (-> new-state event))
+         ;; if we have an exit, push it onto the stack frame
+         ;; and also blow away the old stack frame
+         (if (-> new-state exit)
+             (set! (-> pp stack-frame-top) new-state)
+             (set! (-> pp stack-frame-top) #f)
+             )
+         (set! (-> pp post-hook) (-> new-state post))
+         (set! (-> pp trans-hook) (-> new-state trans))
+         ;; now do the enter
+         (let ((enter-func (-> new-state enter)))
+           (if enter-func
+               (enter-func arg0 arg1 arg2 arg3 arg4 arg5)
+               )
+           )
+         ;; now do the trans
+         (let ((trans-func (-> new-state trans)))
+           (if trans-func
+               (trans-func)
+               )
+           )
+         ;; now we run the code, but in a tricky way.
+         (rlet ((temp)
+                (func)
+                (sp :reg rsp :type uint)
+                (off :reg r15 :type uint)
+                (carg0 :reg rdi)
+                (carg1 :reg rsi)
+                (carg2 :reg rdx)
+                (carg3 :reg rcx))
+           ;; prepare args
+           ;; compiler will likely have these on the stack, we need to get them in regs
+           ;; before messing with the stack.
+           (.mov carg0 arg0)
+           (.mov carg1 arg1)
+           (.mov carg2 arg2)
+           (.mov carg3 arg3)
+
+           ;; get the main code as an x86-64 pointer
+           (.mov func (-> new-state code))
+           (.add func off)
+           ;; reset the stack (scary)
+           (.mov sp (-> pp main-thread stack-top))
+           (.add sp off)
+           ;; push the return trampoline for when code returns.
+           (.mov temp return-from-thread-dead)
+           (.add temp off)
+           (.push temp)
+           ;; and call!
+           (.jr func)
+           ;; stupid hack so the compiler doesn't throw away these registers.
+           (.add carg0 carg1)
+           (.add carg2 carg3)
+           #f ;; can't get here
+           )
+         )
+       )
+      (else
+       ;; not in the main-thread.
+       ;; so we set up the main thread to try again.
+       (set! (-> pp trans-hook) #f)
+       (set-to-run (-> pp main-thread)
+                   enter-state arg0 arg1 arg2 arg3 arg4 arg5)
+       (when (!= (-> pp top-thread name) 'post)
+         ;; abandon this one too.
+         ;; NOTE - this is different from GOAL.
+         ;; GOAL installs this as the return address for this function and returns normally.
+         ;; but we don't because I don't have an easy way to find where to stick this.
+         ;; I can't see how this makes a difference, as all non-main threads seem
+         ;; temporary, but if this turns out to be false, we will need to change this.
+         (rlet ((temp)
+                (off :reg r15 :type uint :reset-here #t))
+           (.mov temp return-from-thread)
+           (.add temp off)
+           (.push temp)
+           (.ret)
+           #f ;; can't get here
+           )
+         )
+       )
+      )
+    )
+  )
+
+(defun send-event-function ((proc process) (msg event-message-block))
+  (with-pp
+    (when (and proc (!= (-> proc type) process-tree) (-> proc event-hook))
+      (let ((pp-backup pp))
+        (set! pp proc)
+        (let ((result ((-> proc event-hook) (-> msg from) (-> msg num-params) (-> msg message) msg)))
+          (set! pp pp-backup)
+          result
+          )
+        )
+      )
+    )
+  )
+
+(defun looping-code ()
+  "Loop."
+  (while #t
+    (suspend)
+    )
+  #f
+  )

goal_src/kernel/gstring-h.gc

@@ -5,6 +5,8 @@
 ;; name in dgo: gstring-h
 ;; dgos: KERNEL
 
+;; generates no code.
+
 (define-extern *string-tmp-str* string)
 (define-extern *temp-string* string)
 (define-extern *stdcon0* string)

goal_src/kernel/gstring.gc

@@ -60,11 +60,88 @@
     )
   )
 
-;; string=
-;; string-charp=
-;; name=
-;; copyn-string<-charp
-;; string<-charp
+(defun string= ((str-a string) (str-b string))
+  "Does str-a hold the same data as str-b?.
+   If either string is null, returns #f."
+  (local-vars (b-ptr (pointer uint8)) (a-ptr (pointer uint8)))
+  (set! a-ptr (-> str-a data))
+  (set! b-ptr (-> str-b data))
+  (if (or (zero? str-a) (zero? str-b))
+      (return '#f)
+      )
+  ;; loop until we reach the end of one string
+  (while (and (nonzero? (-> a-ptr 0)) (nonzero? (-> b-ptr 0)))
+    (if (!= (-> a-ptr 0) (-> b-ptr 0))
+        (return '#f)
+        )
+   (set! a-ptr (&-> a-ptr 1))
+   (set! b-ptr (&-> b-ptr 1))
+   )
+  ;; only equal if both at the end.
+  (and (zero? (-> a-ptr 0)) (zero? (-> b-ptr 0)))
+  )
+
+(defun string-charp= ((str string) (charp (pointer uint8)))
+  "Is the data in str equal to the C string charp?"
+  (local-vars (str-ptr (pointer uint8)))
+  (set! str-ptr (-> str data))
+  (while (and (nonzero? (-> str-ptr 0)) (nonzero? (-> charp 0)))
+    (if (!= (-> str-ptr 0) (-> charp 0))
+        (return '#f)
+        )
+   (set! str-ptr (&-> str-ptr 1))
+   (set! charp (&-> charp 1))
+   )
+  (and (zero? (-> str-ptr 0)) (zero? (-> charp 0)))
+  )
+
+(defun name= ((arg0 basic) (arg1 basic))
+  "Do arg0 and arg1 have the same name?
+   This can use either strings or symbols"
+  (cond
+    ((= arg0 arg1)
+     "Either same symbols, or same string objects, fast check pass!"
+     '#t)
+    ((and (= (-> arg0 type) string) (= (-> arg1 type) string))
+     (string= (the-as string arg0) (the-as string arg1))
+     )
+    ((and (= (-> arg0 type) string) (= (-> arg1 type) symbol))
+     (string= (the-as string arg0) (symbol-to-string arg1))
+     )
+    ((and (= (-> arg1 type) string) (= (-> arg0 type) symbol))
+     (string= (the-as string arg1) (symbol-to-string arg0))
+     )
+    )
+  )
+
+(defun copyn-string<-charp ((str string) (charp (pointer uint8)) (len int))
+  "Copy data from a charp to a GOAL string. Copies len chars, plus a null."
+  (local-vars (str-ptr (pointer uint8)) (i int))
+  (set! str-ptr (-> str data))
+  (set! i 0)
+  (while (< i len)
+    (set! (-> str-ptr 0) (-> charp 0))
+    (set! str-ptr (&-> str-ptr 1))
+    (set! charp (&-> charp 1))
+    (set! i (+ i 1))
+    )
+  (set! (-> str-ptr 0) 0)
+  str
+  )
+
+(defun string<-charp ((str string) (charp (pointer uint8)))
+  "Copy all chars from a char* to a GOAL string.
+   Does NO length checking."
+  (local-vars (str-ptr (pointer uint8)))
+  (set! str-ptr (-> str data))
+  (while (nonzero? (-> charp 0))
+    (set! (-> str-ptr 0) (-> charp 0))
+    (set! str-ptr (&-> str-ptr 1))
+    (set! charp (&-> charp 1))
+    )
+  (set! (-> str-ptr 0) 0)
+  str
+  )
 
 (defun charp<-string ((dst (pointer uint8)) (src-string string))
   "Copy a GOAL string into a character array."
@@ -79,40 +156,564 @@
     )
   )
 
-;; copy-charp<-charp
-;; cat-string<-string
-;; catn-string<-charp
-;; cat-string<-string_to_charp
-;; append-character-to-string
-;; charp-basename
+(defun copy-charp<-charp ((dst (pointer uint8)) (src (pointer uint8)))
+  "C string copy."
+  (while (nonzero? (-> src 0))
+    (set! (-> dst 0) (-> src 0))
+    (set! dst (&-> dst 1))
+    (set! src (&-> src 1))
+    )
+  (set! (-> dst 0) 0)
+  dst
+  )
+
+(defun cat-string<-string ((a string) (b string))
+  "Append b to a. No length checks"
+  (local-vars (a-ptr (pointer uint8))  (b-ptr (pointer uint8)))
+  (set! a-ptr (-> a data))
+  (set! b-ptr (-> b data))
+  ;; seek to the end of a
+  (while (nonzero? (-> a-ptr 0))
+    (nop!)
+    (nop!)
+    (nop!)
+    (set! a-ptr (&-> a-ptr 1))
+    )
+  ;; append b
+  (while (nonzero? (-> b-ptr 0))
+    (set! (-> a-ptr 0) (-> b-ptr 0))
+    (set! a-ptr (&-> a-ptr 1))
+    (set! b-ptr (&-> b-ptr 1))
+    )
+  ;; null terminate
+  (set! (-> a-ptr 0) 0)
+  a
+  )
+
+(defun catn-string<-charp ((a string) (b (pointer uint8)) (len int))
+  "Append b to a, exactly len chars"
+  (local-vars (a-ptr (pointer uint8)) (i int) )
+  (set! a-ptr (-> a data))
+  ;; seek to end of a
+  (while (nonzero? (-> a-ptr 0))
+    (nop!)
+    (nop!)
+    (nop!)
+    (set! a-ptr (&-> a-ptr 1))
+    )
+  ;; append
+  (set! i 0)
+  (while (< i len)
+    (set! (-> a-ptr 0) (-> b 0))
+    (set! a-ptr (&-> a-ptr 1))
+    (set! b (&-> b 1))
+    (set! i (+ i 1))
+    )
+  (set! (-> a-ptr 0) 0)
+  a
+  )
+
+(defun cat-string<-string_to_charp ((a string) (b string) (end-ptr (pointer uint8)))
+  "Append b to a, using chars of b up to (and including) the one pointed to by end-ptr,
+   or, until the end of b, whichever comes first."
+
+  (let ((b-ptr (-> b data))
+        (a-ptr (-> a data))
+        )
+    ;; seek to end of a
+    (while (nonzero? (-> a-ptr 0))
+      (nop!)
+      (nop!)
+      (nop!)
+      (set! a-ptr (&-> a-ptr 1))
+      )
+    (while (and (>= (the-as int end-ptr) (the-as int b-ptr))
+                (nonzero? (-> b-ptr 0)))
+      (set! (-> a-ptr 0) (-> b-ptr 0))
+      (set! a-ptr (&-> a-ptr 1))
+      (set! b-ptr (&-> b-ptr 1))
+      )
+    (set! (-> a-ptr 0) 0)
+    a-ptr
+    )
+  )
+
+
+(defun append-character-to-string ((str string) (char uint8))
+  "Append char to the end of the given string."
+  (let ((str-ptr (-> str data)))
+    (while (nonzero? (-> str-ptr 0))
+      (nop!)
+      (nop!)
+      (nop!)
+      (set! str-ptr (&-> str-ptr 1))
+      )
+    (set! (-> str-ptr 0) char)
+    (set! (-> str-ptr 1) 0)
+    0
+    )
+  )
+
+(defun charp-basename ((charp (pointer uint8)))
+  "Like basename in C"
+  (let ((ptr charp))
+    ;; seek to end
+    (while (nonzero? (-> ptr 0))
+      (set! ptr (&-> ptr 1))
+      )
+    ;; and back up...
+    (while (< (the-as int charp) (the-as int ptr))
+      (set! ptr (&-> ptr -1))
+      ;; (if (or (zero? (+ (-> ptr 0) -47)) (zero? (+ (-> ptr 0) -92)))
+      ;; check for equal to / or \
+      (if (or (= (-> ptr 0) #\/) (= (-> ptr 0) #\\))
+          ;; return the next char after that
+          (return (&-> ptr 1))
+          )
+      )
+    ;; didn't find any slashes, return the whole thing.
+    charp
+    )
+  )
 
 (defun clear ((a0-0 string))
+  "Make string empty"
   (set! (-> a0-0 data 0) 0) a0-0
   )
 
-;; string<?
-;; string>?
-;; string<=?
-;; string>=?
 
+;; NOTE: these string comparisons are a little broken.
+;; ex: (string<? "asd" "asdf") = #f
+;;     (string<? "asdf" "asd") = #f
+;; these comparisons do not properly order strings.
+
+(defun string<? ((a string) (b string))
+  "In dictionary order, is a < b?"
+  (local-vars (i int) (len int))
+
+  ;; get the minimum length.
+  ;; note - we don't do virtual calls here for some reason.
+  (set! len (min ((method-of-type string length) a)
+                 ((method-of-type string length) b)
+                 )
+        )
+
+  ;; loop through chars, up until the minimum length.
+  (set! i 0)
+  (while (< i len)
+   (cond
+    ((< (-> a data i) (-> b data i)) (return '#t))
+    ((< (-> b data i) (-> a data i)) (return '#f))
+    )
+   (set! i (+ i 1))
+   )
+  '#f
+  )
+
+(defun string>? ((a string) (b string))
+  "In dictionary order, is a > b?"
+  (local-vars (i int) (len int))
+  (set! len (min ((method-of-type string length) a)
+                 ((method-of-type string length) b))
+        )
+  (set! i 0)
+  (while (< i len)
+    (cond
+      ((< (-> a data i) (-> b data i)) (return '#f))
+      ((< (-> b data i) (-> a data i)) (return '#t))
+      )
+    (set! i (+ i 1))
+    )
+  '#f
+  )
+
+(defun string<=? ((a string) (b string))
+  (local-vars (i int) (len int))
+  (set! len (min ((method-of-type string length) a)
+                 ((method-of-type string length) b))
+   )
+  (set! i 0)
+  (while
+   (< i len)
+   (cond
+    ((< (-> a data i) (-> b data i)) (return '#t))
+    ((< (-> b data i) (-> a data i)) (return '#f))
+    )
+   (set! i (+ i 1))
+   )
+  '#t
+  )
+
+(defun string>=? ((a string) (b string))
+  (local-vars (i int) (len int))
+  (set! len (min ((method-of-type string length) a)
+                 ((method-of-type string length) b))
+        )
+  (set! i 0)
+  (while (< i len)
+    (cond
+      ((< (-> a data i) (-> b data i)) (return '#f))
+      ((< (-> b data i) (-> a data i)) (return '#t))
+      )
+    (set! i (+ i 1))
+    )
+  '#t
+  )
+
+;; temporary string for argument functions
 (define *string-tmp-str* (new 'global 'string 128 (the string #f)))
 
-;; string-skip-to-char
-;; string-cat-to-last-char
-;; string-skip-whitespace
-;; string-suck-up!
-;; string-strip-leading-whitespace
-;; string-strip-trailing-whitespace
-;; string-strip-whitespace
-;; string-get-arg!!
-;; string->int
-;; string->float
-;; string-get-int32!!
-;; string-get-float!!
-;; string-get-flag!!
+(defun string-skip-to-char ((str (pointer uint8)) (char uint))
+  "Return pointer to first instance of char in C string, or to the null terminator if none"
+  (while (and (nonzero? (-> str 0)) (!= (-> str 0) char))
+    (set! str (&-> str 1))
+    )
+  str
+  )
 
+(defun string-cat-to-last-char ((base-str string) (append-str string) (char uint))
+  "Append append-str to the end of of base-str, up to the last occurance of char in append-str"
+  (local-vars
+   (location-of-char (pointer uint8))
+   (end-of-append (pointer uint8))
+   )
+
+  ;; point to one before the beginning of the append string (kind of a hack)
+  (set! end-of-append (&-> (the-as (pointer uint8) append-str) 3))
+  ;; try to find char in append-str
+  (set! location-of-char (string-skip-to-char (-> append-str data) char))
+  (when (= (-> location-of-char 0) char)
+    ;; found it!
+    (until
+        (begin
+         ;; update the location of the last find
+         (set! end-of-append location-of-char)
+         ;; try to find another
+         (set! location-of-char (string-skip-to-char (&-> location-of-char 1) char))
+         ;; did we succeed?
+         (!= (-> location-of-char 0) char)
+         )
+      (none)
+      )
+    )
+  ;; now location-of-char points to the last occurance.
+  ;; or to 1 before the start of append-str if we never found it.
+  (cat-string<-string_to_charp base-str append-str end-of-append)
+  )
+
+(defmacro is-whitespace-char? (c)
+  ;; 32 = space
+  ;; 9 = \t
+  ;; 13 = \r
+  ;; 10 = \n
+  `(or (= ,c 32)
+       (= ,c 9)
+       (= ,c 13)
+       (= ,c 10)
+       )
+  )
+
+(defun string-skip-whitespace ((arg0 (pointer uint8)))
+  "Skip over spaces, tabs, r's and n's"
+  (while
+      (and (nonzero? (-> arg0 0))
+           (is-whitespace-char? (-> arg0 0))
+           )
+    (set! arg0 (&-> arg0 1))
+    )
+  arg0
+  )
+
+(defun string-suck-up! ((str string) (location (pointer uint8)))
+  "Remove character between the start of string and location.
+   The char pointed to by location is now the first."
+  ;; fast check to do nothing if location points to start already.
+  (when (!= location (-> str data))
+    (let ((str-ptr (-> str data)))
+      ;; copy back
+      (while (nonzero? (-> location 0))
+        (set! (-> str-ptr 0) (-> location 0))
+        (set! str-ptr (&-> str-ptr 1))
+        (set! location (&-> location 1))
+        )
+      ;; null terminate
+      (set! (-> str-ptr 0) 0)
+      )
+    '#f
+    )
+  )
+
+(defun string-strip-leading-whitespace! ((str string))
+  "Remove whitespace at the front of a string"
+  (let ((start-loc (string-skip-whitespace (-> str data))))
+    (string-suck-up! str start-loc)
+    )
+  #f
+  )
+
+(defun string-strip-trailing-whitespace! ((str string))
+  "Remove whitespace at the end of a string"
+  (local-vars (ptr (pointer uint8)))
+  (when (nonzero? ((method-of-type string length) str))
+    (set! ptr (&+ (-> str data)
+                  (the-as uint (+ ((method-of-type string length) str) -1)))
+          )
+    (while (and (>= (the-as int ptr) (the-as int (-> str data)))
+                (is-whitespace-char? (-> ptr 0))
+                )
+      (set! ptr (&-> ptr -1))
+      )
+    (set! (-> ptr 1) 0)
+    )
+  '#f
+  )
+
+(defun string-strip-whitespace! ((arg0 string))
+  "Remove whitespace at the beginning and end of a string"
+  (string-strip-trailing-whitespace! arg0)
+  (string-strip-leading-whitespace! arg0)
+  '#f
+  )
+
+(defun string-get-arg!! ((a-str string) (arg string))
+  "Get the first argument from a whitespace separated list of arguments.
+   The arguments can be in quotes or not.
+   Removes argument from arg string, sucks up white space before the next one
+   Outputs argument to a-str."
+  (local-vars
+   (arg-start (pointer uint8))
+   (v1-11 (pointer uint8))
+   (a0-6 symbol)
+   (a0-20 symbol)
+   (a1-3 (pointer uint8))
+   (a1-9 (pointer uint8))
+   (arg-word-start (pointer uint8))
+   (arg-end (pointer uint8))
+   )
+  ;; seek up the beginning of a word.
+  (set! arg-word-start (string-skip-whitespace (-> arg data)))
+  (cond
+    ((= (-> arg-word-start 0) 34) ;; starts with quote
+     ;; seek past quote to first char of name
+     (set! arg-end (&-> arg-word-start 1))
+     ;; now, find the end
+     (set! arg-start arg-end)
+     (while (and (nonzero? (-> arg-end 0))
+                 ;; (nonzero? (+ (-> arg-end 0) -34))
+                 (!= (-> arg-end 0) 34) ;; quote
+                 )
+       (set! arg-end (&-> arg-end 1))
+       )
+
+     ;; copy to output.
+     (copyn-string<-charp a-str arg-start (- (the-as int arg-end) (the-as uint arg-start)))
+
+     ;; if we got a close quote
+     (when (= (-> arg-end 0) 34)
+       ;; seek past it
+       (set! arg-end (&-> arg-end 1))
+       )
+     (set! a1-3 (string-skip-whitespace arg-end))
+     (string-suck-up! arg a1-3)
+     (return '#t)
+     )
+    ((nonzero? (-> arg-word-start 0))
+
+     (set! v1-11 arg-word-start)
+     (while
+         (and
+          (nonzero? (-> arg-word-start 0))
+          (nonzero? (+ (-> arg-word-start 0) -32))
+          (nonzero? (+ (-> arg-word-start 0) -9))
+          (nonzero? (+ (-> arg-word-start 0) -13))
+          (nonzero? (+ (-> arg-word-start 0) -10))
+          )
+       (set! arg-word-start (&-> arg-word-start 1))
+       )
+     (copyn-string<-charp a-str v1-11 (- (the-as int arg-word-start) (the-as uint v1-11)))
+     (set! a1-9 (string-skip-whitespace arg-word-start))
+     (string-suck-up! arg a1-9)
+     (return '#t)
+     )
+    )
+  '#f
+  )
+
+(defun string->int ((str string))
+  "String to int. Supports binary, hex, and decimal. Negative is implemented for decimal and hex
+   But I think it's broken?"
+  (local-vars
+   (result int)
+   (negative symbol)
+   (str-ptr (pointer uint8))
+   (next-char-1 (pointer uint8))
+   (next-char-2 (pointer uint8))
+   (a0-4 (pointer uint8))
+   (a0-5 symbol)
+   (a1-14 uint)
+   (a1-16 symbol)
+   (a1-20 uint)
+   (a1-23 uint)
+   (a1-33 symbol)
+   (a1-44 symbol)
+   (a1-47 (pointer uint8))
+   )
+  (set! str-ptr (-> str data))
+  (set! result 0)
+  (set! negative '#f)
+  (cond
+    ((= (-> str-ptr 0) 35) ;; #
+     ;; starts with #.
+     (set! next-char-1 (&-> str-ptr 1))
+     (cond
+       ((or (= (-> next-char-1 0) #\x) (= (-> next-char-1 0) #\X))
+        ;; starts with #x or #X
+        (set! next-char-2 (&-> next-char-1 1))
+        (when (= (-> next-char-2 1) #\-)
+          ;; negate!
+          (set! negative '#t)
+          (set! next-char-2 (&-> next-char-2 1))
+          )
+        (while
+            (or
+             ;; is in [0-9]
+             (and
+              (>= (-> next-char-2 0) #\0)
+              (>= (the-as uint #\9) (-> next-char-2 0))
+              )
+             ;; is in [A-F]
+             (and
+              (>= (-> next-char-2 0) (the-as uint 65))
+              (>= (the-as uint 70) (-> next-char-2 0))
+              )
+             ;; is in [a-f]
+             (and
+              (>= (-> next-char-2 0) (the-as uint 97))
+              (>= (the-as uint 102) (-> next-char-2 0))
+              )
+             )
+          (cond
+            ;; is in [A-F]
+            ((and
+              (>= (-> next-char-2 0) (the-as uint 65))
+              (>= (the-as uint 70) (-> next-char-2 0))
+              )
+             (set!
+              result
+              (the int (+ (+ (-> next-char-2 0) -55) (the-as uint (shl result 4))))
+              )
+             )
+            (else
+             (set!
+              a1-16
+              (and
+               (>= (-> next-char-2 0) (the-as uint 97))
+               (>= (the-as uint 102) (-> next-char-2 0))
+               )
+              )
+             (cond
+               (a1-16
+                ;; in [a-f]
+                (set! result
+                 (the int (+ (+ (-> next-char-2 0) -87) (the-as uint (shl result 4))))
+                 )
+                )
+               (else
+                ;; numeric
+                (set! result
+                 (the int (+ (+ (-> next-char-2 0) -48) (the-as uint (shl result 4))))
+                 )
+                ) ;; end numeric
+               ) ;; end numeric or [a-f]
+             ) ;; end not [A-F]
+            ) ;; end cond
+          (set! next-char-2 (&-> next-char-2 1))
+          ) ;; end while
+        )
+       ((or (zero? (+ (-> next-char-1 0) -98)) (zero? (+ (-> next-char-1 0) -66)))
+        ;; is #b (I guess we can't do negative binary?)
+        (set! a0-4 (&-> next-char-1 1))
+        (while (and (>= (-> a0-4 0) (the-as uint 48)) (>= (the-as uint 49) (-> a0-4 0)))
+          (set! result (the int (+ (+ (-> a0-4 0) -48) (the-as uint (shl result 1)))))
+          (set! a0-4 (&-> a0-4 1))
+          )
+        )
+       )
+     )
+    (else
+     ;; decimal
+
+     ;; check for negative
+     (when (= (-> str-ptr 1) 45)
+       (set! negative '#t)
+       (set! str-ptr (&-> str-ptr 1))
+       (set! a1-47 str-ptr)
+       )
+     
+     (while (and
+          (>= (-> str-ptr 0) (the-as uint 48))
+          (>= (the-as uint 57) (-> str-ptr 0))
+          )
+       (set! result (the int (+ (+ (-> str-ptr 0) -48) (the-as uint (* 10 result)))))
+       (set! str-ptr (&-> str-ptr 1))
+       )
+     )
+    )
+  (cond (negative (- result)) (else result))
+  )
+
+(defun string->float ((arg0 string))
+  "Convert a string to a float, but it is not implemented."
+  (format 0 "string->float left as an excersize for the reader~%")
+  0.0
+  )
+
+(defun string-get-int32!! ((arg0 (pointer int32)) (arg1 string))
+  "Get an int32 from a list of arguments"
+  (cond
+   ((string-get-arg!! *string-tmp-str* arg1)
+    (set! (-> arg0 0) (string->int *string-tmp-str*))
+    '#t
+    )
+   (else '#f)
+   )
+  )
+
+(defun string-get-float!! ((arg0 (pointer float)) (arg1 string))
+  (cond
+   ((string-get-arg!! *string-tmp-str* arg1)
+    (set! (-> arg0 0) (string->float *string-tmp-str*))
+    '#t
+    )
+   (else '#f)
+   )
+  )
+
+(defun string-get-flag!! ((result (pointer symbol)) (in string) (first-flag string) (second-flag string))
+  (local-vars (v1-0 symbol))
+  (cond
+    ((string-get-arg!! *string-tmp-str* in)
+     (cond
+       ((or (string= *string-tmp-str* first-flag)
+            (string= *string-tmp-str* second-flag)
+            )
+        (set! (-> result 0) (string= *string-tmp-str* first-flag))
+        '#t
+        )
+       (else '#f)
+       )
+     )
+    (else '#f)
+    )
+  )
+
+;; what is this?
 (define *debug-draw-pauseable* #f)
+
+;; console buffers. not sure what the two are for.
 (define *stdcon0* (new 'global 'string 16384 (the string #f)))
 (define *stdcon1* (new 'global 'string 16384 (the string #f)))
 (define *stdcon* *stdcon0*)
-(define *temp-string* (new 'global 'string 256 (the string #f)))
+
+;; shared temporary string.
+(define *temp-string* (new 'global 'string 256 (the string #f)))

test/decompiler/FormRegressionTest.cpp

@@ -102,6 +102,9 @@ std::unique_ptr<FormRegressionTest::TestData> FormRegressionTest::make_function(
   test->func.analyze_prologue(test->file);
   test->func.cfg = build_cfg(test->file, 0, test->func);
   EXPECT_TRUE(test->func.cfg->is_fully_resolved());
+  if (!test->func.cfg->is_fully_resolved()) {
+    fmt::print("CFG:\n{}\n", test->func.cfg->to_dot());
+  }
 
   auto ops = convert_function_to_atomic_ops(test->func, program.labels);
   test->func.ir2.atomic_ops = std::make_shared<FunctionAtomicOps>(std::move(ops));

test/decompiler/test_FormExpressionBuild.cpp

@@ -2074,12 +2074,9 @@ TEST_F(FormRegressionTest, ExprPrintl) {
       "    daddiu sp, sp, 32";
   std::string type = "(function object object)";
 
-  // todo - I think this is a sign that we're unscrambling method calls in the wrong order.
-  // but I want to wait for a less confusing example before making a change.
   std::string expected =
       "(begin\n"
-      "  (set! a0-1 arg0)\n"
-      "  ((method-of-type (rtype-of a0-1) print) a0-1)\n"
+      "  ((method-of-type (rtype-of a0-1) print) arg0)\n"
       "  (format (quote #t) \"~%\")\n"
       "  arg0\n"
       "  )";
@@ -2355,4 +2352,155 @@ TEST_F(FormRegressionTest, ExprStopwatchElapsedSeconds) {
 
   std::string expected = "(begin (set! v1-0 (abs arg0)) (* (l.f L20) (the float v1-0)))";
   test_with_expr(func, type, expected, false, "");
+}
+
+TEST_F(FormRegressionTest, ExprCopyStringString) {
+  std::string func =
+      "  sll r0, r0, 0\n"
+      "L161:\n"
+      "    daddiu v1, a0, 4\n"
+      "    daddiu a1, a1, 4\n"
+      "    beq r0, r0, L163\n"
+      "    sll r0, r0, 0\n"
+
+      "L162:\n"
+      "    lbu a2, 0(a1)\n"
+      "    sb a2, 0(v1)\n"
+      "    daddiu v1, v1, 1\n"
+      "    daddiu a1, a1, 1\n"
+
+      "L163:\n"
+      "    lbu a2, 0(a1)\n"
+      "    bne a2, r0, L162\n"
+      "    sll r0, r0, 0\n"
+
+      "    or a1, s7, r0\n"
+      "    sb r0, 0(v1)\n"
+      "    or v0, a0, r0\n"
+      "    jr ra\n"
+      "    daddu sp, sp, r0";
+  std::string type = "(function string string string)";
+  std::string expected =
+      "(begin\n"
+      "  (set! v1-0 (-> arg0 data))\n"
+      "  (set! a1-1 (-> arg1 data))\n"
+      "  (while\n"
+      "   (nonzero? (-> a1-1 0))\n"
+      "   (set! (-> v1-0 0) (-> a1-1 0))\n"
+      "   (set! v1-0 (&-> v1-0 1))\n"
+      "   (set! a1-1 (&-> a1-1 1))\n"
+      "   )\n"
+      "  (set! (-> v1-0 0) 0)\n"
+      "  arg0\n"
+      "  )";
+  test_with_expr(func, type, expected, false, "");
+}
+
+TEST_F(FormRegressionTest, StringLt) {
+  std::string func =
+      "  sll r0, r0, 0\n"
+      "L91:\n"
+      "    daddiu sp, sp, -64\n"
+      "    sd ra, 0(sp)\n"
+      "    sq s4, 16(sp)\n"
+      "    sq s5, 32(sp)\n"
+      "    sq gp, 48(sp)\n"
+
+      "    or gp, a0, r0\n"
+      "    or s5, a1, r0\n"
+      "    or a0, gp, r0\n"
+      "    lw v1, string(s7)\n"
+      "    lwu t9, 32(v1)\n"
+      "    jalr ra, t9\n"
+      "    sll v0, ra, 0\n"
+
+      "    or v1, v0, r0\n"
+      "    or s4, v1, r0\n"
+      "    or a0, s5, r0\n"
+      "    lw v1, string(s7)\n"
+      "    lwu t9, 32(v1)\n"
+      "    jalr ra, t9\n"
+      "    sll v0, ra, 0\n"
+
+      "    or v1, v0, r0\n"
+      "    slt a0, s4, v1\n"
+      "    movz s4, v1, a0\n"
+      "    addiu v1, r0, 0\n"
+      "    beq r0, r0, L95\n"
+      "    sll r0, r0, 0\n"
+
+      "L92:\n"
+      "    daddu a0, v1, gp\n"
+      "    lbu a0, 4(a0)\n"
+      "    daddu a1, v1, s5\n"
+      "    lbu a1, 4(a1)\n"
+      "    sltu a0, a0, a1\n"
+      "    beq a0, r0, L93\n"
+      "    or a0, s7, r0\n"
+
+      "    daddiu v1, s7, #t\n"
+      "    or v0, v1, r0\n"
+      "    beq r0, r0, L96\n"
+      "    sll r0, r0, 0\n"
+
+      "    or v1, r0, r0\n"
+      "    beq r0, r0, L94\n"
+      "    sll r0, r0, 0\n"
+
+      "L93:\n"
+      "    daddu a0, v1, s5\n"
+      "    lbu a0, 4(a0)\n"
+      "    daddu a1, v1, gp\n"
+      "    lbu a1, 4(a1)\n"
+      "    sltu a0, a0, a1\n"
+      "    beq a0, r0, L94\n"
+      "    or a0, s7, r0\n"
+
+      "    or v0, s7, r0\n"
+      "    beq r0, r0, L96\n"
+      "    sll r0, r0, 0\n"
+
+      "    or v1, r0, r0\n"
+
+      "L94:\n"
+      "    daddiu v1, v1, 1\n"
+
+      "L95:\n"
+      "    slt a0, v1, s4\n"
+      "    bne a0, r0, L92\n"
+      "    sll r0, r0, 0\n"
+
+      "    or v1, s7, r0\n"
+      "    or v1, s7, r0\n"
+      "    or v0, s7, r0\n"
+
+      "L96:\n"
+      "    ld ra, 0(sp)\n"
+      "    lq gp, 48(sp)\n"
+      "    lq s5, 32(sp)\n"
+      "    lq s4, 16(sp)\n"
+      "    jr ra\n"
+      "    daddiu sp, sp, 64";
+  std::string type = "(function string string symbol)";
+  std::string expected =
+      "(begin\n"
+      "  (set!\n"
+      "   s4-1\n"
+      "   (min\n"
+      "    ((method-of-type string length) arg0)\n"
+      "    ((method-of-type string length) arg1)\n"
+      "    )\n"
+      "   )\n"
+      "  (set! v1-4 0)\n"
+      "  (while\n"
+      "   (< v1-4 s4-1)\n"
+      "   (cond\n"
+      "    ((< (-> arg0 data v1-4) (-> arg1 data v1-4)) (return (quote #t)))\n"
+      "    ((< (-> arg1 data v1-4) (-> arg0 data v1-4)) (return (quote #f)))\n"
+      "    )\n"
+      "   (set! v1-4 (+ v1-4 1))\n"
+      "   )\n"
+      "  (quote #f)\n"
+      "  )";
+  test_with_expr(func, type, expected, false, "");
 }

test/decompiler/test_FormExpressionBuildLong.cpp

@@ -2189,4 +2189,393 @@ TEST_F(FormRegressionTest, ExprValid) {
        {"L315", "ERROR: object #x~X ~S is not a valid object of type '~A' (not in symbol table)~%"},
        {"L314",
         "ERROR: object #x~X ~S is not a valid object of type '~A' (inside symbol table)~%"}});
-}
+}
+
+TEST_F(FormRegressionTest, ExprStringToInt) {
+  std::string func =
+      "    sll r0, r0, 0\n"
+      "L14:\n"
+      "    daddiu a0, a0, 4\n"
+      "    addiu v0, r0, 0\n"
+      "    or v1, s7, r0\n"
+      "    addiu a1, r0, 35\n"
+      "    lbu a2, 0(a0)\n"
+      "    bne a2, a1, L33\n"
+      "    sll r0, r0, 0\n"
+
+      "    daddiu a0, a0, 1\n"
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -120\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    bnel s7, a2, L15\n"
+
+      "    or a1, a2, r0\n"
+
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a2, a1, -88\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L15:\n"
+      "    beq s7, a1, L27\n"
+      "    or a1, s7, r0\n"
+
+      "    daddiu a0, a0, 1\n"
+      "    addiu a1, r0, 45\n"
+      "    lbu a2, 1(a0)\n"
+      "    bne a2, a1, L16\n"
+      "    or a1, s7, r0\n"
+
+      "    daddiu v1, s7, #t\n"
+      "    daddiu a0, a0, 1\n"
+      "    or a1, a0, r0\n"
+
+      "L16:\n"
+      "    beq r0, r0, L23\n"
+      "    sll r0, r0, 0\n"
+      "\n"
+
+      "L17:\n"
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 65\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L18\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 70\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L18:\n"
+      "    beq s7, a1, L19\n"
+      "    sll r0, r0, 0\n"
+
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -55\n"
+      "    dsll a2, v0, 4\n"
+      "    daddu v0, a1, a2\n"
+      "    or a1, v0, r0\n"
+      "    beq r0, r0, L22\n"
+      "    sll r0, r0, 0\n"
+
+      "L19:\n"
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 97\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L20\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 102\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L20:\n"
+      "    beq s7, a1, L21\n"
+      "    sll r0, r0, 0\n"
+
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -87\n"
+      "    dsll a2, v0, 4\n"
+      "    daddu v0, a1, a2\n"
+      "    or a1, v0, r0\n"
+      "    beq r0, r0, L22\n"
+      "    sll r0, r0, 0\n"
+
+      "L21:\n"
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -48\n"
+      "    dsll a2, v0, 4\n"
+      "    daddu v0, a1, a2\n"
+      "    or a1, v0, r0\n"
+
+      "L22:\n"
+      "    daddiu a0, a0, 1\n"
+
+      "L23:\n"
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 48\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L24\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 57\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L24:\n"
+      "    bnel s7, a1, L26\n"
+
+      "    or a1, a1, r0\n"
+
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 65\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L25\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 70\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L25:\n"
+      "    bnel s7, a1, L26\n"
+
+      "    or a1, a1, r0\n"
+
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 97\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L26\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 102\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L26:\n"
+      "    bne s7, a1, L17\n"
+      "    sll r0, r0, 0\n"
+
+      "    or a1, s7, r0\n"
+      "    beq r0, r0, L32\n"
+      "    sll r0, r0, 0\n"
+
+      "L27:\n"
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -98\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    bnel s7, a2, L28\n"
+
+      "    or a1, a2, r0\n"
+
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a2, a1, -66\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L28:\n"
+      "    beq s7, a1, L32\n"
+      "    or a1, s7, r0\n"
+
+      "    daddiu a0, a0, 1\n"
+      "    beq r0, r0, L30\n"
+      "    sll r0, r0, 0\n"
+      "\n"
+
+      "L29:\n"
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -48\n"
+      "    dsll a2, v0, 1\n"
+      "    daddu v0, a1, a2\n"
+      "    daddiu a0, a0, 1\n"
+
+      "L30:\n"
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 48\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L31\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 49\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L31:\n"
+      "    bne s7, a1, L29\n"
+      "    sll r0, r0, 0\n"
+
+      "    or a1, s7, r0\n"
+
+      "L32:\n"
+      "    beq r0, r0, L38\n"
+      "    sll r0, r0, 0\n"
+
+      "L33:\n"
+      "    addiu a1, r0, 45\n"
+      "    lbu a2, 1(a0)\n"
+      "    bne a2, a1, L34\n"
+      "    or a1, s7, r0\n"
+
+      "    daddiu v1, s7, #t\n"
+      "    daddiu a0, a0, 1\n"
+      "    or a1, a0, r0\n"
+
+      "L34:\n"
+      "    beq r0, r0, L36\n"
+      "    sll r0, r0, 0\n"
+
+      "L35:\n"
+      "    lbu a1, 0(a0)\n"
+      "    daddiu a1, a1, -48\n"
+      "    addiu a2, r0, 10\n"
+      "    mult3 a2, a2, v0\n"
+      "    daddu v0, a1, a2\n"
+      "    daddiu a0, a0, 1\n"
+
+      "L36:\n"
+      "    lbu a1, 0(a0)\n"
+      "    sltiu a1, a1, 48\n"
+      "    daddiu a2, s7, 8\n"
+      "    movn a2, s7, a1\n"
+      "    beql s7, a2, L37\n"
+
+      "    or a1, a2, r0\n"
+
+      "    addiu a1, r0, 57\n"
+      "    lbu a2, 0(a0)\n"
+      "    sltu a2, a1, a2\n"
+      "    daddiu a1, s7, 8\n"
+      "    movn a1, s7, a2\n"
+
+      "L37:\n"
+      "    bne s7, a1, L35\n"
+      "    sll r0, r0, 0\n"
+
+      "    or a0, s7, r0\n"
+
+      "L38:\n"
+      "    beq s7, v1, L39\n"
+      "    sll r0, r0, 0\n"
+
+      "    dsubu v0, r0, v0\n"
+      "    beq r0, r0, L39\n"
+      "    sll r0, r0, 0\n"
+
+      "L39:\n"
+      "    jr ra\n"
+      "    daddu sp, sp, r0";
+  std::string type = "(function string int)";
+  std::string expected =
+      "(defun test-function ((arg0 string))\n"
+      "  (local-vars\n"
+      "   (v0-0 int)\n"
+      "   (v1-0 symbol)\n"
+      "   (a0-1 (pointer uint8))\n"
+      "   (a0-2 (pointer uint8))\n"
+      "   (a0-3 (pointer uint8))\n"
+      "   (a0-4 (pointer uint8))\n"
+      "   (a0-5 symbol)\n"
+      "   (a1-8 (pointer uint8))\n"
+      "   (a1-14 uint)\n"
+      "   (a1-16 symbol)\n"
+      "   (a1-20 uint)\n"
+      "   (a1-23 uint)\n"
+      "   (a1-33 symbol)\n"
+      "   (a1-44 symbol)\n"
+      "   (a1-47 (pointer uint8))\n"
+      "   )\n"
+      "  (set! a0-1 (-> arg0 data))\n"
+      "  (set! v0-0 0)\n"
+      "  (set! v1-0 (quote #f))\n"
+      "  (cond\n"
+      "   ((= (-> a0-1 0) 35)\n"
+      "    (set! a0-2 (&-> a0-1 1))\n"
+      "    (cond\n"
+      "     ((or (zero? (+ (-> a0-2 0) -120)) (zero? (+ (-> a0-2 0) -88)))\n"
+      "      (set! a0-3 (&-> a0-2 1))\n"
+      "      (when\n"
+      "       (= (-> a0-3 1) 45)\n"
+      "       (set! v1-0 (quote #t))\n"
+      "       (set! a0-3 (&-> a0-3 1))\n"
+      "       (set! a1-8 a0-3)\n"
+      "       )\n"
+      "      (while\n"
+      "       (or\n"
+      "        (and\n"
+      "         (>= (-> a0-3 0) (the-as uint 48))\n"
+      "         (>= (the-as uint 57) (-> a0-3 0))\n"
+      "         )\n"
+      "        (and\n"
+      "         (>= (-> a0-3 0) (the-as uint 65))\n"
+      "         (>= (the-as uint 70) (-> a0-3 0))\n"
+      "         )\n"
+      "        (and\n"
+      "         (>= (-> a0-3 0) (the-as uint 97))\n"
+      "         (>= (the-as uint 102) (-> a0-3 0))\n"
+      "         )\n"
+      "        )\n"
+      "       (cond\n"
+      "        ((and\n"
+      "          (>= (-> a0-3 0) (the-as uint 65))\n"
+      "          (>= (the-as uint 70) (-> a0-3 0))\n"
+      "          )\n"
+      "         (set! v0-0 (+ (+ (-> a0-3 0) -55) (the-as uint (shl v0-0 4))))\n"
+      "         (set! a1-14 v0-0)\n"
+      "         )\n"
+      "        (else\n"
+      "         (set!\n"
+      "          a1-16\n"
+      "          (and\n"
+      "           (>= (-> a0-3 0) (the-as uint 97))\n"
+      "           (>= (the-as uint 102) (-> a0-3 0))\n"
+      "           )\n"
+      "          )\n"
+      "         (cond\n"
+      "          (a1-16\n"
+      "           (set! v0-0 (+ (+ (-> a0-3 0) -87) (the-as uint (shl v0-0 4))))\n"
+      "           (set! a1-20 v0-0)\n"
+      "           )\n"
+      "          (else\n"
+      "           (set! v0-0 (+ (+ (-> a0-3 0) -48) (the-as uint (shl v0-0 4))))\n"
+      "           (set! a1-23 v0-0)\n"
+      "           )\n"
+      "          )\n"
+      "         )\n"
+      "        )\n"
+      "       (set! a0-3 (&-> a0-3 1))\n"
+      "       )\n"
+      "      )\n"
+      "     ((or (zero? (+ (-> a0-2 0) -98)) (zero? (+ (-> a0-2 0) -66)))\n"
+      "      (set! a0-4 (&-> a0-2 1))\n"
+      "      (while\n"
+      "       (and (>= (-> a0-4 0) (the-as uint 48)) (>= (the-as uint 49) (-> a0-4 0)))\n"
+      "       (set! v0-0 (+ (+ (-> a0-4 0) -48) (the-as uint (shl v0-0 1))))\n"
+      "       (set! a0-4 (&-> a0-4 1))\n"
+      "       )\n"
+      "      )\n"
+      "     )\n"
+      "    )\n"
+      "   (else\n"
+      "    (when\n"
+      "     (= (-> a0-1 1) 45)\n"
+      "     (set! v1-0 (quote #t))\n"
+      "     (set! a0-1 (&-> a0-1 1))\n"
+      "     (set! a1-47 a0-1)\n"
+      "     )\n"
+      "    (while\n"
+      "     (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))\n"
+      "     (set! v0-0 (+ (+ (-> a0-1 0) -48) (the-as uint (* 10 v0-0))))\n"
+      "     (set! a0-1 (&-> a0-1 1))\n"
+      "     )\n"
+      "    )\n"
+      "   )\n"
+      "  (cond (v1-0 (- v0-0)) (else (empty) v0-0))\n"
+      "  )";
+  test_final_function(func, type, expected);
+}

test/goalc/source_templates/kernel/kernel-test.gc

@@ -96,4 +96,96 @@
               1 0 0 0 0 0
               )
   0
+  )
+
+
+(defstate die-state
+    :enter (lambda () (format #t "enter die~%"))
+    :exit (lambda () (format #t "exit die~%"))
+    :code (lambda ()
+            (format #t "time to die!~%")
+            (process-deactivate)
+            (format #t "don't see me~%")
+            )
+    )
+
+(defun xmm-check-code (ax ay az aw)
+  "This function relies on saved xmm register being backed up on a context switch"
+  ;; (declare (print-asm))
+  ;; compiler will put these in xmm8 and xmm9 to keep them from being clobbered
+  (let ((x 12.34)
+        (y 45.63))
+    (dotimes (i 3)
+      (format #t "run xmm-check ~f ~f ~D ~D ~D ~D~%" x y ax ay az aw)
+      ;; should preserve xmm8 and xmm9
+      (suspend)
+      )
+    ;; get the wreck process and make it go to die state.
+    (go-process (process-by-name 'wreck-proc *active-pool*) die-state)
+    (go die-state)
+    (format #t "unreachable~%")
+    )
+  )
+
+(defun xmm-wreck-code (ax ay az aw)
+  "This function intentionally overwrites xmm8 and xmm9 and suspends"
+  (while #t
+    (rlet ((x :class fpr :type float :reg xmm8)
+           (y :class fpr :type float :reg xmm9))
+      (set! x 99.0)
+      (set! y 101.0)
+      (format #t "wreck: ~D ~D ~D ~D~%" ax ay az aw)
+      (suspend)
+      (set! x (+ x 1.0))
+      (set! y (+ y 1.0))
+      )
+    )
+  )
+
+;; a state.
+(defstate xmm-check-state
+    :enter (lambda (x y z w) (format #t "enter check: ~D ~D ~D ~D~%" x y z w))
+    :exit (lambda () (format #t "exit check~%"))
+    :code xmm-check-code
+    )
+
+(defstate xmm-wreck-state
+    :enter (lambda (x y z w) (format #t "enter wreck: ~D ~D ~D ~D~%" x y z w))
+    :exit (lambda () (format #t "exit wreck~%"))
+    :code xmm-wreck-code
+    )
+
+(defun state-test ()
+  (let ((proc (get-process *nk-dead-pool* process 1024)))
+    (activate proc *active-pool* 'check-proc *kernel-dram-stack*)
+    (run-now-in-process proc (lambda (x y z w) (go xmm-check-state x y z w))
+                        9 8 7 6)
+    )
+
+  (let ((proc (get-process *nk-dead-pool* process 1024)))
+    (activate proc *active-pool* 'wreck-proc *kernel-dram-stack*)
+    (run-next-time-in-process proc (lambda (x y z w) (go xmm-wreck-state x y z w))
+                              3 4 5 6)
+    )
+  0
+  )
+
+(defun throw-backup-test ()
+  (rlet ((x :reg xmm10 :class fpr :type float))
+    (set! x 10.10)
+    (let ((proc (get-process *nk-dead-pool* process 1024)))
+      (activate proc *active-pool* 'asdf *kernel-dram-stack*)
+      (format #t "value now is ~f~%" x)
+      (run-now-in-process proc (lambda ()
+                                 (rlet ((x2 :reg xmm10 :class fpr :type float))
+                                   (set! x2 -1.0)
+                                   )
+                                 ;; this will throw back.
+                                 (process-deactivate)
+                                 )
+                          )
+      (format #t "now its ~f~%" x)
+      
+      )
+    )
   )

test/goalc/test_goal_kernel.cpp

@@ -108,4 +108,27 @@ TEST_F(KernelTest, RunFunctionInProcess) {
       "Stack Alignemnt 0/16\n"
       "run-function-in-process result: #f\n";
   EXPECT_EQ(expected, result);
+}
+
+TEST_F(KernelTest, StateAndXmm) {
+  runner.c->run_test_from_string("(ml \"test/goalc/source_templates/kernel/kernel-test.gc\")");
+  std::string result = send_code_and_get_multiple_responses("(state-test)", 5, &runner);
+
+  std::string expected =
+      "0\nenter wreck: 3 4 5 6\nwreck: 3 4 5 6\nenter check: 9 8 7 6\nrun xmm-check 12.3400 "
+      "45.6300 9 8 7 6\nwreck: 3 4 5 6\nrun xmm-check 12.3400 45.6300 9 8 7 6\nwreck: 3 4 5 6\nrun "
+      "xmm-check 12.3400 45.6300 9 8 7 6\nwreck: 3 4 5 6\nexit check\nenter die\ntime to "
+      "die!\nexit die\nexit wreck\nenter die\ntime to die!\nexit die\n";
+  EXPECT_EQ(expected, result);
+}
+
+TEST_F(KernelTest, ThrowXmm) {
+  runner.c->run_test_from_string("(ml \"test/goalc/source_templates/kernel/kernel-test.gc\")");
+  std::string result = send_code_and_get_multiple_responses("(throw-backup-test)", 1, &runner);
+
+  std::string expected =
+      "value now is 10.1000\n"
+      "now its 10.1000\n"
+      "0\n";
+  EXPECT_EQ(expected, result);
 }