jak-project/goal_src/jak2/kernel/gkernel.gc

;;-*-Lisp-*-
(in-package goal)

;; name: gkernel.gc
;; name in dgo: gkernel
;; dgos: KERNEL

;; og:ignore-errors:true
;; og:ignore-form:defun kernel-dispatcher

;; forward declared stuff
(define-extern *kernel-clock* clock)
(define-extern *debug-dead-pool* dead-pool-heap)
(define-extern *null-process* process)
(define-extern *vis-boot* symbol)
(define-extern *listener-process* process)
(define-extern *active-pool* process-tree)
(define-extern *default-level* level)

(define-extern change-parent (function process-tree process-tree process-tree))
(define-extern search-process-tree (function process-tree (function process-tree object) process-tree))
(define-extern iterate-process-tree (function process-tree (function object object) kernel-context object))
(define-extern execute-process-tree (function process-tree (function object object) kernel-context object))
(define-extern inspect-process-tree (function process-tree int int symbol process-tree))
(define-extern process-disconnect (function process int))

;; DECOMP BEGINS

;; Version constants
(define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*)))
(define *irx-version* (the-as binteger #x200000))

;; Boot options
(define *kernel-boot-mode* 'listener)
(define *kernel-boot-level* #f)
(define *use-old-listener-print* #f)

;; Stats
(define *deci-count* 0)
(define *last-loado-length* 0)
(define *last-loado-global-usage* 0)
(define *last-loado-debug-usage* 0)

(defmethod relocate object ((obj object) (arg0 int))
  "Most general relocate method."
  obj
  )

;;;;;;;;;;;;;;;;;;
;; Package
;;;;;;;;;;;;;;;;;;

(define *kernel-packages* '())

(defun load-package ((arg0 string) (arg1 kheap))
  "Load a package by name to the given heap."
  (when (not (nmember arg0 *kernel-packages*))
    (kmemopen global arg0)
    (dgo-load arg0 arg1 (link-flag output-load-msg output-load-true-msg execute-login print-login) #x200000)
    (set! *kernel-packages* (cons arg0 *kernel-packages*))
    (kmemclose)
    *kernel-packages*
    )
  )

(defun unload-package ((arg0 string))
  "Mark a package as unloaded."
  (let ((v1-0 (nmember arg0 *kernel-packages*)))
    (if v1-0
        (set! *kernel-packages* (delete! (car v1-0) *kernel-packages*))
        )
    )
  *kernel-packages*
  )

;;;;;;;;;;;;;;;;;;
;; Kernel Globals
;;;;;;;;;;;;;;;;;;

;; the global kernel-context
(define *kernel-context*
        (new 'static 'kernel-context
             :prevent-from-run (process-mask execute sleep)
             :next-pid 3
             :current-process #f
             :relocating-process #f
             :low-memory-message #t
             )
        )

;; the main execution stack that's not on the scratchpad
;; (define *canary-1* (the-as (pointer uint64) (malloc 'global 8)))
(define *dram-stack* (the-as (pointer uint8) (malloc 'global DPROCESS_STACK_SIZE)))
;; (define *canary-2* (the-as (pointer uint64) (malloc 'global 8)))

;; DECOMP DEVIATION
;; the top of the stack.
(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE))
;; DECOMP DEVIATION

;; the top of the scratchpad stack
(set! (-> *kernel-context* fast-stack-top) (the-as pointer #x70004000))

(define *null-kernel-context* (new 'static 'kernel-context))

;;;;;;;;;;;;;;;;;;;;;;;
;; PC Port Scratchpad
;;;;;;;;;;;;;;;;;;;;;;;

;; DECOMP DEVIATION
(#cond
  (PC_PORT
  ;; we'll create a fake scratchpad:
  ;; make sure the scratchpad is 64kb aligned, and make it 32 kB so we can big stacks on it.
  ;; some (partially buggy) code in generic tie relies on 64 kB alignment.
  (let* ((mem (new 'global 'array 'uint8 (* 128 1024)))
         )
      (define *fake-scratchpad-data* (the pointer (align-n mem (* 64 1024))))
    )

  ;; use the same memory for the scratchpad stacks.
  ;; defining it as a separate thing so we can split them for debugging stack corruption easily.
  (define *fake-scratchpad-stack* *fake-scratchpad-data*)
  ;; (define *canary-3* (the-as (pointer uint64) (malloc 'global 8)))

  (defmacro scratchpad-start ()
    "Get the start of the scratchpad. At least 64kB aligned."
    '*fake-scratchpad-data*
    )
  )
  (else
    (defmacro scratchpad-start ()
      #x70000000
      )
    )
  )

(defmacro scratchpad-end ()
  "Get the end of the scratchpad memory"
  `(&+ (scratchpad-start) (* 16 1024))
  )

(defmacro in-scratchpad? (x)
  "Is the given address in the scratchpad?"
  `(and
     (>= (the-as int ,x) (scratchpad-start))
     (< (the-as int ,x) (scratchpad-end))
     )
  )
;; DECOMP DEVIATION

;;;;;;;;;;;;;
;; Thread
;;;;;;;;;;;;;

(defmethod delete thread ((obj thread))
  "Restore the previous thread as the top-thread."
  ;; make sure we aren't actually trying to delete the main thread.
  (when (= obj (-> obj process main-thread))
    (break!)
    )
  (set! (-> obj process top-thread) (the-as cpu-thread (-> obj previous)))
  (none)
  )

(defmethod print thread ((obj thread))
  (format #t "#<~A ~S of ~S pc: #x~X @ #x~X>" (-> obj type) (-> obj name) (-> obj process name) (-> obj pc) obj)
  obj
  )

(defmethod stack-size-set! thread ((obj thread) (arg0 int))
  "Modify the backup stack size of a thread. Must be called from the main thread, before any
   allocations have been done on the process heap."
  (let ((a2-0 (-> obj process)))
    (cond
      ((!= obj (-> a2-0 main-thread))
       (format 0 "ERROR: illegal attempt change stack size of ~A when the main-thread is not the top-thread.~%" a2-0)
       )
      ((= (-> obj stack-size) arg0)
       )
      ((= (-> a2-0 heap-cur) (+ (+ (-> obj stack-size) -4 (-> obj type size)) (the-as int obj)))
       (set! (-> a2-0 heap-cur) (the-as pointer (+ (+ arg0 -4 (-> obj type size)) (the-as int obj))))
       (set! (-> obj stack-size) arg0)
       )
      (else
        (format 0 "ERROR: illegal attempt change stack size of ~A after more heap allocation has occured.~%" a2-0)
        )
      )
    )
  (none)
  )

(defmethod new cpu-thread ((allocation symbol) (type-to-make type) (parent-process process) (name symbol) (arg2 int) (stack-top pointer))
    "Create a new CPU thread. If there is no main thread, it will allocate the main thread on the process.
  If there is already a main thread, it will allocate a temporary thread on the given stack.
  Sets the thread as the top-thread of the process
  This is a special new method which ignores the allocation symbol.
  The stack-top is for the execution stack.
  The stack-size is for the backup stack (applicable for main thread only)"
  (let ((v0-0 (cond
                ((-> parent-process top-thread)
                 ;; this is just a temporary thread, throw the thread on the bottom of the stack
                 (the cpu-thread (&+ stack-top (- PROCESS_STACK_SIZE *gtype-basic-offset*)))
                 )
                (else
                  ;; this is the main thread, allocate it from the process heap.
                  (let ((v1-2 (logand -16 (&+ (-> parent-process heap-cur) 15))))
                    (set! (-> parent-process heap-cur) (&+ (&+ v1-2 (-> type-to-make size)) arg2))
                    (the cpu-thread (&+ v1-2 4))
                    )
                  )
                )
              )
        )
    (set! (-> v0-0 type) type-to-make)
    (set! (-> v0-0 name) name)
    (set! (-> v0-0 process) parent-process)
    (set! (-> v0-0 sp) stack-top)
    (set! (-> v0-0 stack-top) stack-top)
    (set! (-> v0-0 previous) (-> parent-process top-thread))
    (set! (-> parent-process top-thread) v0-0)
    (set! (-> v0-0 suspend-hook) (method-of-object v0-0 thread-suspend))
    (set! (-> v0-0 resume-hook) (method-of-object v0-0 thread-resume))
    (set! (-> v0-0 stack-size) arg2)
    v0-0
    )
  )

(defmethod asize-of cpu-thread ((obj cpu-thread))
  "Get the size in memory of a cpu-thread."
  (the-as int (+ (-> obj type size) (-> obj stack-size)))
  )

;;;;;;;;;;;;;;;
;; Process
;;;;;;;;;;;;;;;

(defbehavior remove-exit process ()
  "Remove a single stack frame.
   This can be used to skip an exit of a state, but it's a bit of a hack."
  (if (-> self stack-frame-top)
      (set! (-> self stack-frame-top) (-> self stack-frame-top next))
      )
  0
  (none)
  )

;; decomp deviation
(defun-debug stream<-process-mask ((arg0 object) (arg1 process-mask))
  "Print a process mask."
  (bit-enum->string process-mask arg1 arg0)
  arg1
  )
;; decomp deviation

(define *master-mode* 'game)
(define *pause-lock* #f)

(defmethod print process-tree ((obj process-tree))
  "Print a process tree."
  (format #t "#<~A ~S @ #x~X>" (-> obj type) (-> obj name) obj)
  obj
  )

(defmethod new process-tree ((allocation symbol) (type-to-make type) (arg0 string))
  "Allocate a new process-tree with the given name."
  (let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> v0-0 name) arg0)
    (set! (-> v0-0 mask) (process-mask process-tree))
    (set! (-> v0-0 clock) *kernel-clock*)
    (set! (-> v0-0 parent) (the-as (pointer process-tree) #f))
    (set! (-> v0-0 brother) (the-as (pointer process-tree) #f))
    (set! (-> v0-0 child) (the-as (pointer process-tree) #f))
    (set! (-> v0-0 self) v0-0)
    (set! (-> v0-0 ppointer) (the-as (pointer process) (&-> v0-0 self)))
    v0-0
    )
  )

(defmethod inspect process-tree ((obj process-tree))
  "Inspect a process-tree"
  (format #t "[~8x] ~A~%" obj (-> obj type))
  (format #t "~Tname: ~S~%" (-> obj name))
  (format #t "~1Tmask: #x~X : (process-mask " (-> obj mask))
  (stream<-process-mask #t (-> obj mask))
  (format #t ")~%")
  (format #t "~Tclock: ~A~%" (-> obj clock))
  (format #t "~Tparent: ~A~%" (ppointer->process (-> obj parent)))
  (format #t "~Tbrother: ~A~%" (ppointer->process (-> obj brother)))
  (format #t "~Tchild: ~A~%" (ppointer->process (-> obj child)))
  obj
  )

(defmethod new process ((allocation symbol) (type-to-make type) (arg0 string) (arg1 int))
  "Allocate or initialize a process."
  ;; check if we got a symbol (for a heap) or just a plain address.
  (let ((v0-0 (if (logtest? (the-as int allocation) 1)
                  (object-new allocation type-to-make (the-as int (+ (-> process size) arg1))) ;; allocate on heap
                  (the process (+ (the-as int allocation) 4)) ;; just use it as an address, do an in-place initialization.
                  )
              )
        )
    (set! (-> v0-0 name) arg0)
    (set! (-> v0-0 clock) *kernel-clock*)
    (set! (-> v0-0 status) 'dead)
    (set! (-> v0-0 pid) 0)
    (set! (-> v0-0 pool) #f)
    (set! (-> v0-0 allocated-length) arg1)
    (set! (-> v0-0 top-thread) #f)
    (set! (-> v0-0 main-thread) #f)
    (let ((v1-6 (-> v0-0 stack)))
      (set! (-> v0-0 heap-cur) v1-6)
      (set! (-> v0-0 heap-base) v1-6)
      )
    (set! (-> v0-0 heap-top)
          (&-> v0-0 stack (-> v0-0 allocated-length))
          )
    (set! (-> v0-0 stack-frame-top) (the-as stack-frame (-> v0-0 heap-top))) ;; bug, probably kheap overlapping this.
    (set! (-> v0-0 stack-frame-top) #f)
    (set! (-> v0-0 state) #f)
    (set! (-> v0-0 next-state) #f)
    (set! (-> v0-0 entity) #f)
    (set! (-> v0-0 level) #f)
    (set! (-> v0-0 trans-hook) #f)
    (set! (-> v0-0 post-hook) #f)
    (set! (-> v0-0 event-hook) #f)
    (set! (-> v0-0 parent) (the-as (pointer process-tree) #f))
    (set! (-> v0-0 brother) (the-as (pointer process-tree) #f))
    (set! (-> v0-0 child) (the-as (pointer process-tree) #f))
    (set! (-> v0-0 self) v0-0)
    (set! (-> v0-0 ppointer) (the-as (pointer process) (&-> v0-0 self)))
    v0-0
    )
  )

(defun inspect-process-heap ((obj process))
  "Inspect each object on the process heap."
  (let ((ptr (&+ (-> obj heap-base) *gtype-basic-offset*))) ; point to first basic
    ;; loop over objects
    (while (< (the int ptr) (the int (-> obj heap-cur)))
      ;; inspect the object
      (inspect (the basic ptr))
      ;; seek to the next object on the heap.
      (&+! ptr (the int (align16 (asize-of (the basic ptr)))))
      )
    )
  #f
  )

(defmethod inspect process ((obj process))
  "Inspect process and all objects on the heap.. Autogenerated proces inspects will eventually call this one."
  (format #t "[~8x] ~A~%" obj (-> obj type))
  (format #t "~Tname: ~S~%" (-> obj name))
  (format #t "~1Tmask: #x~X : (process-mask " (-> obj mask))
  (stream<-process-mask #t (-> obj mask))
  (format #t ")~%")
  (format #t "~Tclock: ~A~%" (-> obj clock))
  (format #t "~Tstatus: ~A~%" (-> obj status))
  (format #t "~Tmain-thread: ~A~%" (-> obj main-thread))
  (format #t "~Ttop-thread: ~A~%" (-> obj top-thread))
  (format #t "~Tentity: ~A~%" (-> obj entity))
  (format #t "~Tlevel: ~A~%" (-> obj level))
  (format #t "~Tstate: ~A~%" (-> obj state))
  (format #t "~Tnext-state: ~A~%" (-> obj next-state))
  (format #t "~Ttrans-hook: ~A~%" (-> obj trans-hook))
  (format #t "~Tpost-hook: ~A~%" (-> obj post-hook))
  (format #t "~Tevent-hook: ~A~%" (-> obj event-hook))
  (format #t "~Tparent: ~A~%" (ppointer->process (-> obj parent)))
  (format #t "~Tbrother: ~A~%" (ppointer->process (-> obj brother)))
  (format #t "~Tchild: ~A~%" (ppointer->process (-> obj child)))
  (format #t "~Tconnection-list: ~`connectable`P~%" (-> obj connection-list))
  (format #t "~Tstack-frame-top: ~A~%" (-> obj stack-frame-top))
  (format #t "~Theap-base: #x~X~%" (-> obj heap-base))
  (format #t "~Theap-top: #x~X~%" (-> obj heap-top))
  (format #t "~Theap-cur: #x~X~%" (-> obj heap-cur))
  (let ((s5-0 *print-column*))
    (set! *print-column* (+ *print-column* *tab-size*))
    (format #t "----~%")
    (inspect-process-heap obj)
    (format #t "----~%")
    (set! *print-column* s5-0)
    )
  (format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
  (format #t "~Tstack[~D] @ #x~X~%" (-> obj allocated-length) (-> obj stack))
  obj
  )

(defmethod asize-of process ((obj process))
  "Get the size in memory of a process."
  (the-as int (+ (-> process size) (-> obj allocated-length)))
  )

(defmethod print process ((obj process))
  "Print a process."

  ;; new: for jak 2, they don't print garbage stack/heap sizes when the process isn't
  ;; activated yet.
  (cond
    ((and (-> obj top-thread) (!= (-> obj status) 'dead))
     (format #t "#<~A ~S ~A :state ~S "
             (-> obj type)
             (-> obj name)
             (-> obj status)
             (if (-> obj state) (-> obj state name))
             )
     (format #t ":stack ~D/~D :heap ~D/~D @ #x~X>"
       (&- (-> obj top-thread stack-top) (the-as uint (-> obj top-thread sp)))
       (-> obj main-thread stack-size)
       (- (-> obj allocated-length) (&- (-> obj heap-top) (the-as uint (-> obj heap-cur))))
       (-> obj allocated-length)
       obj
       )
     )
    (else
      (format #t "#<~A ~S ~A :state ~S @ #x~X"
        (-> obj type)
        (-> obj name)
        (-> obj status)
        (if (-> obj state)
            (-> obj state name)
            )
        obj
        )
      )
    )
  obj
  )

;; decomp deviation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Context Suspend And Resume - Kernel
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; the following functions are used for going from the kernel to threads and back.
;; saved registers: rbx, rbp, r10, r11, r12

;; DANGER - THE KERNEL DOES NOT SAVE ITS FLOATING POINT CONTEXT!!!!

;; we use this to store a GOAL pointer to the kernel's stack pointer when executing user code.
;; to get back to the kernel, we use this global symbol.
(define-extern *kernel-sp* pointer)

(defun return-from-thread ()
  "Context switch to the saved kernel context now.
  This is intended to be jumped to with the ret instruction (return trampoline)
  at the end of a normal function, so this should preserve rax.
  To make sure this happens, all ops should be asm ops and we should have no
  GOAL expressions."
  (declare (asm-func none)
                                        ;(print-asm)
           )
  (rlet ((sp :reg rsp :type uint)
         (off :reg r15 :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (s2 :reg r10 :type uint)
         (s3 :reg r11 :type uint)
         (s4 :reg r12 :type uint)
         )
    ;; get the kernel stack pointer as a GOAL pointer (won't use a temp reg)
    (.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" and modifying saved registers without backing up.
    (.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
    ;; rax should still contain the return value.
    (.ret)
    )
  )

(defun return-from-thread-dead ()
  "Like return from thread, but we clean up our process with deactivate first.
  The return register is not preserved here, instead we return the value of deactivate"
  (declare (asm-func none)
                                        ;(print-asm)
           )
  (rlet ((pp :reg r13 :type process)
         (sp :reg rsp :type uint)
         (off :reg r15 :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (s2 :reg r10 :type uint)
         (s3 :reg r11 :type uint)
         (s4 :reg r12 :type uint)
         )

    ;; first call the deactivate method.
    (deactivate pp)
    ;; 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)
    )
  )

(defmacro abandon-thread ()
  ;; 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) ;; could probably just call this...
    (.add temp off)
    (.push temp)
    (.ret)
    )
  )

(defun reset-and-call ((obj thread) (func function))
  "Make the given thread the top thread, reset the stack, and call the function.
  Sets up a return trampoline so when the function returns it will return to the
  kernel context. Will NOT deactivate on return, so this is intended for temporary threads.
  NOTE: this should only be done from the kernel, running on the
  kernel's stack."
  (declare (asm-func object)
           )

  (rlet ((pp :reg r13 :type process)
         (sp :reg rsp :type uint)
         (off :reg r15 :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (s2 :reg r10 :type uint)
         (s3 :reg r11 :type uint)
         (s4 :reg r12 :type uint)
         (temp :reg rax :type uint)
         )

    ;; set up the process pointer
    (set! pp (-> obj process))
    ;; mark the process as running and set its top thread
    (set! (-> pp status) 'running)
    (set! (-> pp top-thread) (the cpu-thread obj))

    ;; 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?

    ;; setup the rsp for the new thread
    (set! sp (the uint (-> obj stack-top)))
    (.add sp off)

    ;; push the return trampoline to the stack for the user code to return to
    (set! temp (the uint return-from-thread))
    (.add temp off)
    (.push temp)    ;; stack now 16 + 8 aligned
    ;; and call the function!
    (.add func off)
    (.jr func)
    )
  )

(defmethod thread-suspend cpu-thread ((unused cpu-thread))
  "Suspend the thread and return to the kernel."

  (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
  ;; temp registers?
  (rlet ((obj :reg r13 :type cpu-thread)
         (temp :reg rax :type uint)
         (off :reg r15 :type uint)
         (sp :reg rsp :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (s2 :reg r10 :type uint)
         (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)
         )

    ;; 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))

    ;; 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 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!
        ;; if you hit this, try with DEBUG_PRINT_SUSPEND_FAIL set to #t (see gkernel-h.gc)
        ;; it will print more info before reaching here.
        )

      ;; 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)
  )

(defmethod thread-resume cpu-thread ((thread-to-resume cpu-thread))
  "Resume a suspended thread. Call this from the kernel only.
   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)
           )

  (rlet ((obj :reg r13 :type cpu-thread)
         (temp :reg rax :type uint)
         (off :reg r15 :type uint)
         (sp :reg rsp :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (s2 :reg r10 :type uint)
         (s3 :reg r11 :type uint)
         (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)

    ;; 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)

    ;; 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))
        )
      )

    ;; 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)
    (.add a4 a4)
    (.add a5 a5)
    )
  (none)
  )
;; decomp deviation


(defmethod new dead-pool ((allocation symbol) (type-to-make type) (arg0 int) (arg1 int) (arg2 string))
  "Allocate a tree of dead processes."
  (let ((s3-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> s3-0 name) arg2)
    (set! (-> s3-0 mask) (process-mask process-tree))
    (set! (-> s3-0 parent) (the-as (pointer process-tree) #f))
    (set! (-> s3-0 brother) (the-as (pointer process-tree) #f))
    (set! (-> s3-0 child) (the-as (pointer process-tree) #f))
    (set! (-> s3-0 self) s3-0)
    (set! (-> s3-0 ppointer) (the-as (pointer process) (&-> s3-0 self)))
    (dotimes (s2-1 arg0)
      (let ((s1-0 (-> s3-0 child))
            (v1-5 ((method-of-type process new) allocation process "dead" arg1))
            )
        (set! (-> s3-0 child) (process->ppointer v1-5))
        (set! (-> v1-5 parent) (process->ppointer (the-as process s3-0)))
        (set! (-> v1-5 pool) s3-0)
        (set! (-> v1-5 brother) s1-0)
        )
      )
    s3-0
    )
  )

;; decomp deviation
(defmethod get-process dead-pool ((obj dead-pool) (arg0 type) (arg1 int))
  "Try to get a process from this dead pool. If it fails, try the debug dead pool and complain."

  ;; grab the first child
  (let ((s4-0 (the-as object (-> obj child))))
    (when (and (not (the-as (pointer process-tree) s4-0)) *debug-segment* (!= obj *debug-dead-pool*))
      ;; didn't work, but we have the debug dead pool to try
      ;; NOTE: this is a type bug here, s4-0 should be (pointer process), but this uses process.
      (set! s4-0 (get-process *debug-dead-pool* arg0 arg1))

      (if (the-as process s4-0)
          ;; that worked. complain.
          (format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
            arg0
            #f ;; (ppointer->process (the-as process s4-0)) bugged in original game
            (-> obj name)
            )
          )
      ;; this didn't work right in the original game, just crash here.
      (break)
      )
    (cond
      (s4-0
        ;; got a process somehow, set the type and return.
        (set! (-> (the-as (pointer process) s4-0) 0 type) arg0)
        (-> (the-as (pointer process) s4-0) 0)
        )
      (else
        ;; didn't work, complain and return #f.
        (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
          arg0
          (ppointer->process (the-as (pointer process) s4-0))
          (-> obj name)
          )
        (the-as process #f)
        )
      )
    )
  )
;; decomp deviation

(defmethod return-process dead-pool ((obj dead-pool) (arg0 process))
  "Return a process to the dead pool."
  (change-parent arg0 obj)
  (none)
  )

(defmethod new dead-pool-heap ((allocation symbol) (type-to-make type) (arg0 string) (arg1 int) (arg2 int))
  "Allocate a new dead-pool-heap"
  (let ((s2-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* 12 arg1))))))
    (set! (-> s2-0 name) arg0)
    (set! (-> s2-0 mask) (process-mask process-tree))
    (set! (-> s2-0 allocated-length) arg1)
    (set! (-> s2-0 parent) (the-as (pointer process-tree) #f))
    (set! (-> s2-0 brother) (the-as (pointer process-tree) #f))
    (set! (-> s2-0 child) (the-as (pointer process-tree) #f))
    (set! (-> s2-0 self) s2-0)
    (set! (-> s2-0 ppointer) (the-as (pointer process) (&-> s2-0 self)))
    (init s2-0 allocation arg2)
    s2-0
    )
  )

(defmethod init dead-pool-heap ((obj dead-pool-heap) (arg0 symbol) (arg1 int))
  "Initialize the heap."

  ;; setup the records in a linked list, all referring to *null-process*.
  (countdown (v1-0 (-> obj allocated-length))
    (let ((a0-4 (-> obj process-list v1-0)))
      (set! (-> a0-4 process) *null-process*)
      (set! (-> a0-4 next) (-> obj process-list (+ v1-0 1)))
      )
    )

  ;; set the dead list to that list
  (set! (-> obj dead-list next) (the-as dead-pool-heap-rec (-> obj process-list)))

  ;; clear alive list
  (set! (-> obj alive-list process) #f)

  ;; terminate dead list.
  (set! (-> obj process-list (+ (-> obj allocated-length) -1) next) #f)
  (set! (-> obj alive-list prev) (-> obj alive-list))
  (set! (-> obj alive-list next) #f)
  (set! (-> obj alive-list process) #f)
  (set! (-> obj first-gap) (-> obj alive-list))
  (set! (-> obj first-shrink) #f)

  (cond
    ((zero? arg1)
     ;; explicit support for a 0 size heap.
     (set! (-> obj heap base) (the-as pointer 0))
     (set! (-> obj heap current) (the-as pointer 0))
     (set! (-> obj heap top) (the-as pointer 0))
     (set! (-> obj heap top-base) (the-as pointer 0))
     0
     )
    (else
      ;; otherwise allocate a heap.
      (set! (-> obj heap base) (malloc arg0 arg1))
      (set! (-> obj heap current) (-> obj heap base))
      (set! (-> obj heap top) (&+ (-> obj heap base) arg1))
      (set! (-> obj heap top-base) (-> obj heap top))
      )
    )
  (none)
  )

(defmethod gap-location dead-pool-heap ((obj dead-pool-heap) (arg0 dead-pool-heap-rec))
  "Get the location of the first possible gap after the given record."
  (the-as pointer
    (if (-> arg0 process)
        ;; if we have a process, after that process
        (+ (+ (-> arg0 process allocated-length) -4 (-> process size)) (the-as int (-> arg0 process)))
        ;; no process, just the start of the dead pool's big heap.
        (-> obj heap base)
        )
    )
  )

(defmethod gap-size dead-pool-heap ((obj dead-pool-heap) (arg0 dead-pool-heap-rec))
  "Get the size of the gap after the given record (possibly 0)"
  (cond
    ((-> arg0 process)
     ;; record has a proc
     (let ((v1-3 (&+ (&+ (the-as pointer (-> arg0 process)) (-> process size)) (-> arg0 process allocated-length))))
       (if (-> arg0 next)
           ;; and there's a next process, just get the gap in between those
           (&- (the-as pointer (-> arg0 next process)) (the-as uint v1-3))
           ;; no next process, the gap is just the distance to the end of the dead pool's heap.
           (&- (-> obj heap top) (the-as uint (&+ v1-3 4)))
           )
       )
     )
    ((-> arg0 next)
     ;; record has no proc, go from start of dead pool heap to the next process.
     (&- (the-as pointer (-> arg0 next process)) (the-as uint (&+ (-> obj heap base) 4)))
     )
    (else
      ;; no processes at all, the gap is the entire heap.
      (&- (-> obj heap top) (the-as uint (-> obj heap base)))
      )
    )
  )

(defmethod find-gap dead-pool-heap ((obj dead-pool-heap) (arg0 dead-pool-heap-rec))
  "Iterate through records, starting at the given one, and find the first one with a gap after it."
  (while (and (-> arg0 next) (zero? (gap-size obj arg0)))
    (set! arg0 (-> arg0 next))
    )
  arg0
  )

(defmethod inspect dead-pool-heap ((obj dead-pool-heap))
  "Inspect a dead-pool heap, printing proccesses and gaps."
  (format #t "[~8x] ~A~%" obj (-> obj type))
  (format #t "~Tname: ~A~%" (-> obj name))
  (format #t "~1Tmask: #x~X : (process-mask " (-> obj mask))
  (stream<-process-mask #t (-> obj mask))
  (format #t ")~%")
  (format #t "~Tparent: #x~X~%" (-> obj parent))
  (format #t "~Tbrother: #x~X~%" (-> obj brother))
  (format #t "~Tchild: #x~X~%" (-> obj child))
  (format #t "~Tppointer: #x~X~%" (-> obj ppointer))
  (format #t "~Tself: ~A~%" (-> obj self))
  (format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
  (format #t "~Theap: #<kheap @ #x~X>~%" (-> obj heap))
  (format #t "~Tfirst-gap: #<dead-pool-heap-rec @ #x~X>~%" (-> obj first-gap))
  (format #t "~Tfirst-shrink: #<dead-pool-heap-rec @ #x~X>~%" (-> obj first-shrink))
  (format #t "~Talive-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj alive-list))
  (format #t "~Tlast: #<dead-pool-heap-rec @ #x~X>~%" (-> obj alive-list prev))
  (format #t "~Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj dead-list))
  (let* ((s5-0 (&- (-> obj heap top) (the-as uint (-> obj heap base))))
         (v1-3 (if (-> obj alive-list prev)
                   (gap-size obj (-> obj alive-list prev))
                   s5-0
                   )
               )
         )
    (format #t "~Tprocess-list[0] @ #x~X     ~D/~D bytes used~%" (-> obj process-list) (- s5-0 v1-3) s5-0)
    )
  (let ((s5-1 (-> obj alive-list))
        (s4-0 0)
        )
    (while s5-1
      (if (-> s5-1 process)
          (format #t "~T  [~3D] #<dead-pool-heap-rec @ #x~X>  ~A~%" s4-0 s5-1 (-> s5-1 process))
          )
      (let ((s3-0 (gap-size obj s5-1)))
        (if (nonzero? s3-0)
            (format #t "~T   gap: ~D bytes @ #x~X~%" s3-0 (gap-location obj s5-1))
            )
        )
      (set! s5-1 (-> s5-1 next))
      (+! s4-0 1)
      )
    )
  obj
  )

(defmethod asize-of dead-pool-heap ((obj dead-pool-heap))
  "Get the size in memory of a dead-pool-heap."
  (the-as int (+ (-> obj type size) (* 12 (-> obj allocated-length))))
  )

(defmethod memory-used dead-pool-heap ((obj dead-pool-heap))
  "Get the amount of used memory. Gaps in between processes are considered used."
  (if (-> obj alive-list prev)
      (- (memory-total obj) (gap-size obj (-> obj alive-list prev)))
      0
      )
  )

(defmethod memory-total dead-pool-heap ((obj dead-pool-heap))
  "Get the total size of the heap."
  (&- (-> obj heap top) (the-as uint (-> obj heap base)))
  )

(defmethod memory-free dead-pool-heap ((obj dead-pool-heap))
  "Get the amount of free memory. Does not include gaps in between processes."
  (let ((v1-0 (-> obj heap top)))
    (if (-> obj alive-list prev)
        (gap-size obj (-> obj alive-list prev))
        (&- v1-0 (the-as uint (-> obj heap base)))
        )
    )
  )

(defmethod compact-time dead-pool-heap ((obj dead-pool-heap))
  "Not working, likely was supposed to return how long the compaction took."
  ;; never set.
  (-> obj compact-time)
  )

(defmethod find-gap-by-size dead-pool-heap ((obj dead-pool-heap) (arg0 int))
  "Find the first gap which is at least the given size."
  (let ((gp-0 (-> obj first-gap)))
    (while (and gp-0 (< (gap-size obj gp-0) arg0))
      (set! gp-0 (-> gp-0 next))
      )
    gp-0
    )
  )

(defmethod get-process dead-pool-heap ((obj dead-pool-heap) (arg0 type) (arg1 int))
  "Get a process!"
  (let ((s4-0 (-> obj dead-list next))
        (s3-0 (the-as process #f))
        )
    ;; find a gap!
    (let ((s1-0 (find-gap-by-size obj (the-as int (+ (-> process size) arg1)))))
      (cond
        ((and s4-0 s1-0 (nonzero? (-> obj heap base))) ;; have record, gap, and heap, we are good!
         ;; get record
         (set! (-> obj dead-list next) (-> s4-0 next))
         (let ((v1-6 (-> s1-0 next)))
           (set! (-> s1-0 next) s4-0)
           (set! (-> s4-0 next) v1-6)
           (if v1-6
               (set! (-> v1-6 prev) s4-0)
               )
           )
         (set! (-> s4-0 prev) s1-0)
         (if (= s1-0 (-> obj alive-list prev))
             (set! (-> obj alive-list prev) s4-0)
             )

         ;; construct process in-place
         (let ((a0-5 (gap-location obj s1-0)))
           (set! s3-0 ((method-of-type process new) (the-as symbol a0-5) process "process" arg1))
           )

         ;; link process to record
         (set! (-> s4-0 process) s3-0)
         (set! (-> s3-0 ppointer) (&-> s4-0 process))

         ;; update gap/shrinks
         (if (= (-> obj first-gap) s1-0)
             (set! (-> obj first-gap) (find-gap obj s4-0))
             )
         (if (or (not (-> obj first-shrink)) (< (the-as int s3-0) (the-as int (-> obj first-shrink process))))
             (set! (-> obj first-shrink) s4-0)
             )

         ;; setup process
         (set! (-> s3-0 parent) (-> obj ppointer))
         (set! (-> s3-0 pool) obj)
         (set! (-> obj child) (&-> s4-0 process))
         )
        (else
          (when (and *debug-segment* (!= obj *debug-dead-pool*))
            (set! s3-0 (get-process *debug-dead-pool* arg0 arg1))
            (if (and s3-0 *vis-boot*)
                (format
                  0
                  "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
                  arg0
                  s3-0
                  (-> obj name)
                  )
                )
            )
          )
        )
      )
    (if s3-0
        (set! (-> s3-0 type) arg0)
        (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" arg0 s3-0 (-> obj name))
        )
    s3-0
    )
  )

;; decomp deviation
(defmethod return-process dead-pool-heap ((obj dead-pool-heap) (proc process))
  "Return a process to a dead pool heap"

  ;; check we are returning to the correct pool
  (unless (eq? obj (-> proc pool))
    (format 0 "ERROR: process ~A does not belong to dead-pool-heap ~A.~%" proc obj)
    )

  ;; reclaim us.
  (change-parent proc obj)

  ;; we don't maintain a real tree for a dead-pool-heap, so undo any change to child
  ;; done by change-parent
  (set! (-> obj child) #f)

  ;; we know our ppointer is really a rec for a dead-pool-heap process, so we can use
  ;; this trick to quickly find our rec.
  (let ((rec (the dead-pool-heap-rec (-> proc ppointer))))

    ;; if we are at or below the first gap, update first gap.
    (when (or (eq? (-> obj first-gap) rec)
              (< (the int (gap-location obj rec)) (the int (gap-location obj (-> obj first-gap))))
              )
      (set! (-> obj first-gap) (-> rec prev))
      )


    ;; update the first-shrink. We aren't smart about this and just move it backward.
    (when (eq? (-> obj first-shrink) rec)
      (set! (-> obj first-shrink) (-> rec prev))
      (when (not (-> obj first-shrink process))
        (set! (-> obj first-shrink) #f))
      )

    ;; remove us from list
    (set! (-> rec prev next) (-> rec next))
    (cond
      ((-> rec next)
       ;; update links
       (set! (-> rec next prev) (-> rec prev))
       )
      (else
       ;; we were last, update that.
       (set! (-> obj last) (-> rec prev))
       )
      )

    ;; insert at the front of the dead list.
    (set! (-> rec next) (-> obj dead-list next))
    (set! (-> obj dead-list next) rec)
    (set! (-> rec process) *null-process*)

    (none)
    )
  )

(defmethod shrink-heap dead-pool-heap ((obj dead-pool-heap) (proc process))
  "Shrink the heap of a process.
   This resizes the process heap to be the exact size it is currently using."
  (when proc
    ;; get our rec.
    (let ((rec (the dead-pool-heap-rec (-> proc ppointer))))
      ;; check if it's ok to shrink
      (unless (or (process-mask? (-> proc mask) heap-shrunk)  ;; already shrunk
                  (and (not (-> proc next-state))             ;; uninitialized
                       (not (-> proc state)))                 ;; uninitialized
                  )
        ;; shrink!
        (set! (-> proc allocated-length) (the int (&- (-> proc heap-cur) (-> proc stack))))
        (set! (-> proc heap-top) (&-> (-> proc stack) (-> proc allocated-length)))

        ;; update first gap
        (when (< (the int proc) (the int (gap-location obj (-> obj first-gap))))
          (set! (-> obj first-gap) (find-gap obj rec))
          )

        ;; mark us as shrunk
        (process-mask-set! (-> proc mask) heap-shrunk)
        )

      ;; update first shrink
      (when (eq? (-> obj first-shrink) rec)
        (set! (-> obj first-shrink) (-> rec next))
        )
      )
    )
  obj
  )
;; decomp deviation

(defmethod compact dead-pool-heap ((obj dead-pool-heap) (arg0 int))
  "Relocate processes to remove gaps and increase free memory."

  ;; skip if we're an empty dead-pool-heap
  (if (zero? (-> obj heap base))
      (return 0)
      )

  ;; if we're almost out of memory, increase the compaction amount.
  (let* ((s4-0 (memory-free obj))
         (v1-5 (memory-total obj))
         (f0-2 (/ (the float s4-0) (the float v1-5)))
         )
    (cond
      ((< f0-2 0.1)
       (set! arg0 1000)
       ;; really low, complain.
       (if (and *debug-segment* (-> *kernel-context* low-memory-message))
           (format *stdcon* "~3LLow Actor Memory~%~0L")
           )
       )
      ((< f0-2 0.2)
       (set! arg0 (* arg0 4))
       )
      ((< f0-2 0.3)
       (set! arg0 (* arg0 2))
       )
      )
    )
  (set! (-> obj compact-count-targ) (the-as uint arg0))
  (set! (-> obj compact-count) (the-as uint 0))

  ;; loop over compactions.
  (while (nonzero? arg0)
    (+! arg0 -1)

    ;; try to get something to shrink
    (let ((v1-19 (-> obj first-shrink)))
      (when (not v1-19)
        (set! v1-19 (-> obj alive-list next))
        (set! (-> obj first-shrink) v1-19)
        )
      (if v1-19
          ;; got something, shrink it.
          (shrink-heap obj (-> v1-19 process))
          )
      )

    ;; move to fill the gap.
    (let ((s4-1 (-> obj first-gap)))
      (when (-> s4-1 next)
        (let ((s3-0 (-> s4-1 next process))
              (s2-0 (gap-size obj s4-1))
              )
          (when (nonzero? s2-0)
            (when (< s2-0 0)
              ;; bug, negative size.
              (break!)
              )
            ;; shrink before moving.
            (shrink-heap obj s3-0)
            ;; do the relocation! the relocate method of process does the actual memcpy.
            (relocate s3-0 (- s2-0))
            ;; update gaps
            (set! (-> obj first-gap) (find-gap obj s4-1))
            (+! (-> obj compact-count) 1)
            )
          )
        )
      )
    )
  0
  (none)
  )

(defmethod churn dead-pool-heap ((obj dead-pool-heap) (arg0 int))
  "Relocate processes to debug process relocation."
  (while (nonzero? arg0)
    (+! arg0 -1)
    (let ((s4-0 (-> obj alive-list next)))
      (when s4-0
        (if (or (= (-> obj first-gap) s4-0)
                (< (the-as int (gap-location obj s4-0)) (the-as int (gap-location obj (-> obj first-gap))))
                )
            (set! (-> obj first-gap) (-> s4-0 prev))
            )
        (when (= (-> obj first-shrink) s4-0)
          (set! (-> obj first-shrink) (-> s4-0 prev))
          (if (not (-> obj first-shrink process))
              (set! (-> obj first-shrink) #f)
              )
          )
        (set! (-> s4-0 prev next) (-> s4-0 next))
        (if (-> s4-0 next)
            (set! (-> s4-0 next prev) (-> s4-0 prev))
            (set! (-> obj alive-list prev) (-> s4-0 prev))
            )
        (let ((a1-3 (-> obj alive-list prev)))
          (let ((v1-19 (-> a1-3 next)))
            (set! (-> a1-3 next) s4-0)
            (set! (-> s4-0 next) v1-19)
            (if v1-19
                (set! (-> v1-19 prev) s4-0)
                )
            )
          (set! (-> s4-0 prev) a1-3)
          (set! (-> obj alive-list prev) s4-0)
          (set! (-> s4-0 process)
                (relocate (-> s4-0 process) (&- (gap-location obj a1-3) (the-as uint (&-> (-> s4-0 process) type))))
                )
          )
        )
      )
    )
  0
  (none)
  )

(defun method-state ((arg0 type) (arg1 basic))
  "Get a state by name from the method table of a type."
  (dotimes (v1-0 (the-as int (-> arg0 allocated-length)))
    (let ((a2-2 (the-as basic (-> arg0 method-table v1-0))))
      (if (and (nonzero? (the-as function a2-2))
               (= (-> (the-as function a2-2) type) state)
               (= (-> (the-as state a2-2) name) arg1)
               )
          (return (the-as state a2-2))
          )
      )
    )
  (the-as state #f)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Searching and Iterating
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; goal lambdas don't "capture" variables successfully, so this is a workaround.
(define *global-search-name* (the-as basic #f))
(define *global-search-count* 0)

(defun process-by-name ((arg0 string) (arg1 process-tree))
  "Get a process by name."
  (set! *global-search-name* arg0)
  (the-as process (search-process-tree
                    arg1
                    (lambda ((arg0 process)) (string= (-> arg0 name) (the-as string *global-search-name*)))
                    )
          )
  )

(defun process-not-name ((arg0 string) (arg1 process-tree))
  "Get a process that doesn't have the given name."
  (set! *global-search-name* (the-as basic arg0))
  (the-as
    process
    (search-process-tree
      arg1
      (lambda ((arg0 process)) (not (string= (-> arg0 name) (the-as string *global-search-name*))))
      )
    )
  )

(defun process-count ((arg0 process-tree))
  "Count the number of processes in the given tree."
  (set! *global-search-count* 0)
  (iterate-process-tree
    arg0
    (lambda ((arg0 process)) (set! *global-search-count* (+ *global-search-count* 1)) #t)
    *null-kernel-context*
    )
  *global-search-count*
  )

(defun kill-by-name ((arg0 string) (arg1 process-tree))
  "Kill all processes with the given name."
  (local-vars (a0-1 process))
  (while (begin (set! a0-1 (process-by-name arg0 arg1)) a0-1)
    (deactivate a0-1)
    )
  #f
  )

(defun kill-by-type ((arg0 type) (arg1 process-tree))
  "Kill all processes with the given type."
  (local-vars (a0-1 process-tree))
  (set! *global-search-name* arg0)
  (while (begin
           (set! a0-1 (search-process-tree arg1 (lambda ((arg0 process)) (= (-> arg0 type) *global-search-name*))))
           a0-1
           )
    (deactivate a0-1)
    )
  #f
  )

(defun kill-not-name ((arg0 string) (arg1 process-tree))
  "Kill all processes, except for ones named this."
  (local-vars (a0-1 process))
  (while (begin (set! a0-1 (process-not-name arg0 arg1)) a0-1)
    (deactivate a0-1)
    )
  #f
  )

(defun kill-not-type ((arg0 type) (arg1 process-tree))
  "Kill all processes not of the given type."
  (local-vars (a0-1 process-tree))
  (set! *global-search-name* arg0)
  (while (begin
           (set! a0-1 (search-process-tree arg1 (lambda ((arg0 process)) (!= (-> arg0 type) *global-search-name*))))
           a0-1
           )
    (deactivate a0-1)
    )
  #f
  )

(defmethod run-logic? process ((obj process))
  "Should this process be run by the kernel?"
  #t
  )

(defun iterate-process-tree ((arg0 process-tree) (arg1 (function object object)) (arg2 kernel-context))
  "Iterate over the process tree, calling the function on each process."
  (let ((s4-0 (or (logtest? (-> arg0 mask) (process-mask process-tree)) (arg1 arg0))))
    (cond
      ((= s4-0 'dead)
       ;; the function returned dead, don't look at children.
       )
      (else
        ;; iterate over children too.
        (let ((v1-4 (-> arg0 child)))
          (while v1-4
            (let ((s3-1 (-> v1-4 0 brother)))
              (iterate-process-tree (-> v1-4 0) arg1 arg2)
              (set! v1-4 s3-1)
              )
            )
          )
        )
      )
    s4-0
    )
  )

(defun execute-process-tree ((arg0 process-tree) (arg1 (function object object)) (arg2 kernel-context))
  "Iterate over the process tree, running only if the mask doesn't prevent it.
   Update the mask of the process-tree to have kernel-run if and only if we run at least one process."

  ;; start with this cleared
  (logclear! (-> arg0 mask) (process-mask kernel-run))

  ;; prevent run if:
  ;;  - we are a process-tree
  ;;  - we are prevent-from-run
  ;;  - we don't return #t for run-logic?
  (let ((s3-0 (or (logtest? (-> arg0 mask) (process-mask process-tree))
                  ;; prevent if not both (clear to run and run-logic? = #t)
                  (not (and (zero? (logand (-> arg2 prevent-from-run) (-> arg0 mask))) (run-logic? arg0)))
                  (begin (logior! (-> arg0 mask) (process-mask kernel-run)) (arg1 arg0))
                  )
              )
        )
    (cond
      ((= s3-0 'dead)
       ;; don't check children if dead.
       )
      (else
        (let ((v1-12 (-> arg0 child)))
          (while v1-12
            (let ((s4-1 (-> v1-12 0 brother)))
              (execute-process-tree (-> v1-12 0) arg1 arg2)
              (set! v1-12 s4-1)
              )
            )
          )
        )
      )
    s3-0
    )
  )

(defun search-process-tree ((arg0 process-tree) (arg1 (function process-tree object)))
  "Iterate process tree, returning the process that returns #t first."
  (when (zero? (logand (-> arg0 mask) (process-mask process-tree)))
    (if (arg1 arg0)
        (return arg0)
        )
    )
  (let ((v1-5 (-> arg0 child)))
    (while v1-5
      (let ((s5-1 (-> v1-5 0 brother)))
        (let ((v1-6 (search-process-tree (-> v1-5 0) arg1)))
          (if v1-6
              (return v1-6)
              )
          )
        (set! v1-5 s5-1)
        )
      )
    )
  (the-as process-tree #f)
  )

;; decomp deviation
(defun kernel-dispatcher ()
  "Main entry point to GOAL from C++."

  ;; added
  ;; outside of all profiler events, set a ROOT event
  (profiler-instant-event "ROOT")

  ;; run any listener functions
  (when *listener-function*
    (set! *enable-method-set* (+ *enable-method-set* 1))
    (let ((t1-0 (reset-and-call (-> *listener-process* main-thread) *listener-function*)))
      (if *use-old-listener-print*
          (format #t "~D~%" t1-0 t1-0 t1-0)
          (format #t "~D        #x~X        ~F        ~A~%" t1-0 t1-0 t1-0 t1-0)
          )
      )
    (set! *listener-function* #f)
    (set! *enable-method-set* (+ *enable-method-set* -1))
    )

  ;; for each active proces...
  (execute-process-tree
    *active-pool*
    (lambda ((arg0 process))
      ;; (+! (-> *canary-1*) 1)
      ;; (+! (-> *canary-2*) 1)
      ;; (+! (-> *canary-3*) 1)
      (let ((s5-0 *kernel-context*))
        (case (-> arg0 status)
          (('waiting-to-run 'suspended)
           ;; we'll run this process
           (profiler-start-event (-> arg0 name))
           (set! (-> s5-0 current-process) arg0)
           (cond
             ((logtest? (-> arg0 mask) (process-mask pause))
              ;; we can be paused, write messages/debug-draw to buffers that aren't cleared
              ;; when the game is paused.
              (set! *stdcon* *stdcon1*)
              (set! *debug-draw-pauseable* #t)
              )
             (else
               ;; not pausable, write to buffers that clear each frame.
               (set! *stdcon* *stdcon0*)
               (set! *debug-draw-pauseable* #f)
               )
             )

           ;; run the trans function.
          ;;  (format 0 "Trans | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
           (when (-> arg0 trans-hook)
             (let ((s4-0 (new 'process 'cpu-thread arg0 'trans 256 (-> arg0 main-thread stack-top))))
               (with-pc-profiler "trans"
                  (reset-and-call s4-0 (-> arg0 trans-hook))
                  )
               (delete s4-0)
               )
             (when (= (-> arg0 status) 'dead) ;; handle deactivates in trans
               (set! (-> s5-0 current-process) #f)
               (profiler-end-event)
               (return 'dead)
               )
             )

           ;; run the main thread!
          ;;  (format 0 "Code | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
           (if (logtest? (-> arg0 mask) (process-mask sleep-code))
               (set! (-> arg0 status) 'suspended)
               (with-pc-profiler "code"
                 ((-> arg0 main-thread resume-hook) (-> arg0 main-thread))
                 )
               )
          ;;  (format 0 "Finished Code | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))


           (cond
             ((= (-> arg0 status) 'dead) ;; handle death in main thread.
              (set! (-> s5-0 current-process) #f)
              (profiler-end-event)
              'dead
              )
             (else
               ;; run post.
               ;; NOTE: post always runs on the dram stack, so you can use ja-post and use the scratchpad for anims.
              ;;  (format 0 "Post | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
               (when (-> arg0 post-hook)
                 (let ((s4-1 (new 'process 'cpu-thread arg0 'post 256 *kernel-dram-stack*)))
                   (with-pc-profiler "post"
                     (reset-and-call s4-1 (-> arg0 post-hook))
                     )
                   (delete s4-1)
                   )
                 (when (= (-> arg0 status) 'dead) ;; handle death in post
                   (set! (-> s5-0 current-process) #f)
                   (profiler-end-event)
                   (return 'dead)
                   )
                 (set! (-> arg0 status) 'suspended)
                 )
               ;; done with process.
               (set! (-> s5-0 current-process) #f)
               (profiler-end-event)
               #f
               )
             )
           )
          (('dead)
           'dead
           )
          )
        )
      )
    *kernel-context*
    )
  )

#|
(defun kernel-dispatcher ()
  "Run the kernel!
   This is the entry point from C++ to GOAL."

  ;; outside of all profiler events, set a ROOT event
  (profiler-instant-event "ROOT")

  ;; execute the listener function, if we got one.
  (when *listener-function*
    (+! *enable-method-set* 1) ;; allow out-of-order method definitions (slower)
    ;; (let ((result (reset-and-call (-> *listener-process* main-thread) *listener-function*))) ;; run function!
    (let ((result (*listener-function*)))
      ;; print result.
      (if *use-old-listener-print*
          (format #t "~D~%" result result result)
          (format #t "~D        #x~X        ~F        ~A~%" result result result result)
          )
      )
    ;; clear pending function
    (set! *listener-function* #f)
    (+! *enable-method-set* -1)
    )
  )

|#
;; decomp deviation

(defun sync-dispatcher ()
  "Run just the listener function. Used for SQL query stuff."
  (let ((t9-0 *listener-function*))
    (the-as object (when t9-0
                     (set! *listener-function* #f)
                     (t9-0)
                     #f
                     )
            )
    )
  )

(defun inspect-process-tree ((arg0 process-tree) (arg1 int) (arg2 int) (arg3 symbol))
  "Print out a process tree diagram."
  (print-tree-bitmask arg2 arg1)
  (cond
    (arg3
      (format #t "__________________~%")
      (format
        #t
        "~S~A~%"
        (if (zero? arg1)
            ""
            "+---"
            )
        arg0
        )
      (let ((s2-0 *print-column*))
        (set! *print-column* (the binteger (* arg1 4)))
        (inspect arg0)
        (set! *print-column* s2-0)
        )
      )
    (else
      (format
        #t
        "~S~A~%"
        (if (zero? arg1)
            ""
            "+---"
            )
        arg0
        )
      )
    )
  (let ((s2-1 (-> arg0 child)))
    (while s2-1
      (inspect-process-tree
        (-> s2-1 0)
        (+ arg1 1)
        (if (not (-> s2-1 0 brother))
            arg2
            (logior arg2 (ash 1 (+ arg1 1)))
            )
        arg3
        )
      (set! s2-1 (-> s2-1 0 brother))
      )
    )
  arg0
  )

(defmacro set-u128-as-u64! (dst src)
  `(set! (-> (the (pointer uint64) (& ,dst)))
         ,src
         )
  )

(defmacro set-u64-from-u128! (dst src)
  `(set! ,dst (-> (the (pointer uint64) (& ,src))))
  )

(defmacro the-super-u64-fucntion (func)
  `(the-as (function uint uint uint uint uint uint object) ,func)
  )

;; decomp deviation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stack Frame Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The GOAL kernel supports dynamic throw and catch.
;; The catch frames are managed per process (you can't throw to a frame outside your process)
;; But otherwise it is fully dynamic.

(defmethod new catch-frame ((allocation symbol) (type-to-make type) (name symbol) (func function) (param-block (pointer uint64)))
  "Run func in a catch frame with the given 8 parameters.
  The return value is the result of the function.
  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)
           (allow-saved-regs) ;; very dangerous!
           )

  (rlet ((pp :reg r13 :type process)
         (temp :reg rax :type uint)
         (off :reg r15 :type uint)
         (sp :reg rsp :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (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 (&+ (the pointer 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 bits
      (.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))

      ;; 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)

      ;; 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)
        )
      )
    )
  )

(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))

  (rlet ((pp :reg r13 :type process)
         (temp :reg rax :type uint)
         (off :reg r15 :type uint)
         (sp :reg rsp :type uint)
         (s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (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))

    ;; 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)

    ;; 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)
    )
  )

(defun throw ((name symbol) value)
  "Dynamic throw."
  (rlet ((pp :reg r13 :type process))
    (let ((cur (-> pp stack-frame-top)))
      (while cur
        (when (and (eq? (-> cur name) name) (eq? (-> cur type) catch-frame))
          ;; match!

          (throw-dispatch (the catch-frame cur) value)
          )

        (if (eq? (-> cur type) protect-frame)
            ;; call the cleanup function
            ((-> (the protect-frame cur) exit))
            )
        (set! cur (-> cur next))
        )
      )
    )
  (format 0 "ERROR: throw could not find tag ~A~%" name)
  (break)
  )
;; decomp deviation

(defmethod new protect-frame ((allocation symbol) (type-to-make type) (arg0 (function none)))
  "Create a new protect frame, must be on the stack."
  (with-pp
    (let ((v0-0 (the-as protect-frame (+ (the-as int allocation) 4))))
      (set! (-> v0-0 type) type-to-make)
      (set! (-> v0-0 name) 'protect-frame)
      (set! (-> v0-0 exit) arg0)
      (set! (-> v0-0 next) (-> pp stack-frame-top))
      (set! (-> pp stack-frame-top) v0-0)
      v0-0
      )
    )
  )

(defun previous-brother ((arg0 process-tree))
  (let ((v1-0 (-> arg0 parent)))
    (when v1-0
      (let ((v1-2 (-> v1-0 0 child)))
        (if (= v1-2 arg0)
            (return (the-as object #f))
            )
        (while v1-2
          (if (= (-> v1-2 0 brother) arg0)
              (return (the-as object v1-2))
              )
          (set! v1-2 (-> v1-2 0 brother))
          )
        )
      (the-as (pointer process-tree) #f)
      )
    )
  )

(defun change-parent ((arg0 process-tree) (arg1 process-tree))
  (let ((a2-0 (-> arg0 parent)))
    (when a2-0
      (let ((v1-2 (-> a2-0 0 child)))
        (cond
          ((= (ppointer->process v1-2) arg0)
           (set! (-> a2-0 0 child) (-> arg0 brother))
           )
          (else
            (while (!= (ppointer->process (-> v1-2 0 brother)) arg0)
              (nop!)
              (nop!)
              (nop!)
              (set! v1-2 (-> v1-2 0 brother))
              )
            (set! (-> v1-2 0 brother) (-> arg0 brother))
            )
          )
        )
      )
    )
  (set! (-> arg0 parent) (-> arg1 ppointer))
  (set! (-> arg0 brother) (-> arg1 child))
  (set! (-> arg1 child) (-> arg0 ppointer))
  arg0
  )

(defun change-brother ((arg0 process-tree) (arg1 process-tree))
  (when (and arg0 (!= (-> arg0 brother) arg1) (!= arg0 arg1))
    (let ((a2-1 (-> arg0 parent)))
      (when a2-1
        (let ((t0-0 (-> a2-1 0 child))
              (a3-1 (the-as (pointer process-tree) #f))
              (v1-4 (the-as (pointer process-tree) #f))
              )
          (if (= (ppointer->process t0-0) arg0)
              (set! a3-1 a2-1)
              )
          (if (= (ppointer->process t0-0) arg1)
              (set! v1-4 a2-1)
              )
          (while (and (-> t0-0 0 brother) (or (not a3-1) (not v1-4)))
            (if (= (-> (ppointer->process t0-0) brother) arg1)
                (set! v1-4 t0-0)
                )
            (if (= (-> (ppointer->process t0-0) brother) arg0)
                (set! a3-1 t0-0)
                )
            (set! t0-0 (-> t0-0 0 brother))
            )
          (cond
            ((or (not a3-1) (not v1-4))
             (return 0)
             )
            ((= a3-1 a2-1)
             (set! (-> a3-1 5) (the-as process-tree (-> arg0 brother)))
             )
            (else
              (set! (-> a3-1 4) (the-as process-tree (-> arg0 brother)))
              )
            )
          (cond
            ((= v1-4 a2-1)
             (set! (-> arg0 brother) (the-as (pointer process-tree) (-> v1-4 5)))
             (set! (-> v1-4 5) (the-as process-tree (-> arg0 ppointer)))
             )
            (else
              (set! (-> arg0 brother) (the-as (pointer process-tree) (-> v1-4 4)))
              (set! (-> v1-4 4) (the-as process-tree (-> arg0 ppointer)))
              )
            )
          )
        )
      )
    )
  arg0
  )

(defun change-to-last-brother ((arg0 process-tree))
  (when (and (-> arg0 brother) (-> arg0 parent))
    (let* ((a1-0 (-> arg0 parent))
           (v1-4 (-> a1-0 0 child))
           )
      (cond
        ((= (-> v1-4 0) arg0)
         (set! (-> a1-0 0 child) (-> arg0 brother))
         )
        (else
          (while (!= (-> v1-4 0 brother 0) arg0)
            (nop!)
            (nop!)
            (nop!)
            (nop!)
            (set! v1-4 (-> v1-4 0 brother))
            )
          (set! (-> v1-4 0 brother) (-> arg0 brother))
          )
        )
      (while (-> v1-4 0 brother)
        (nop!)
        (nop!)
        (nop!)
        (nop!)
        (set! v1-4 (-> v1-4 0 brother))
        )
      (set! (-> v1-4 0 brother) (-> arg0 ppointer))
      )
    (set! (-> arg0 brother) (the-as (pointer process-tree) #f))
    )
  arg0
  )

;; decomp deviation
(defmethod activate process ((obj process) (arg0 process-tree) (arg1 basic) (arg2 pointer))
  "Start a process!"
  ;; if we got the scratchpad stack, move to the fake scratchpad.
  (#when PC_PORT
    (when (= arg2 *scratch-memory-top*)
      (set! arg2 (&+ *fake-scratchpad-stack* (* 32 1024)))
      )
    )
  (set! (-> obj mask) (logclear (-> arg0 mask) (process-mask sleep sleep-code process-tree heap-shrunk)))

  ;; inherit clock
  (set! (-> obj clock) (-> arg0 clock))
  (set! (-> obj status) 'ready)
  ;; get unique pid
  (let ((v1-5 (-> *kernel-context* next-pid)))
    (set! (-> obj pid) v1-5)
    (set! (-> *kernel-context* next-pid) (+ v1-5 1))
    )
  (set! (-> obj top-thread) #f)
  (set! (-> obj main-thread) #f)
  (set! (-> obj name) (the-as string arg1))
  ;; adjust heap to leave a gap for child of process fields
  (let ((v1-10 (&-> obj stack (-> obj type heap-base))))
    (set! (-> obj heap-cur) v1-10)
    (set! (-> obj heap-base) v1-10)
    )
  (set! (-> obj stack-frame-top) #f)
  ;; clear the heap
  (mem-set32! (-> obj stack) (the-as int (shr (-> obj type heap-base) 2)) 0)
  (set! (-> obj trans-hook) #f)
  (set! (-> obj post-hook) #f)
  (set! (-> obj event-hook) #f)
  (set! (-> obj state) #f)
  (set! (-> obj next-state) #f)
  (cond
    ((logtest? (-> arg0 mask) (process-mask process-tree))
     ;; spawned with a tree as the parent, which doesn't have a level/entity. So pick defaults
     (set! (-> obj entity) #f)
     (set! (-> obj level) *default-level*)
     )
    (else
      ;; parent is another process, inherit level/entity.
      (set! (-> obj entity) (-> (the-as process arg0) entity))
      (set! (-> obj level) (-> (the-as process arg0) level))
      )
    )
  (set! (-> obj connection-list next1) #f)
  (set! (-> obj connection-list prev1) #f)
  ;; set up main thread that can be suspended.
  (set! (-> obj main-thread) (new 'process 'cpu-thread obj 'code 256 arg2))
  ;; move to the active pool
  (change-parent obj arg0)
  )

(defun run-function-in-process ((obj process) (func function) a0 a1 a2 a3 a4 a5)
  "Switch to the given process and run the function. This is used to initialize a process.
  The function will run until it attempts to change state. At the first attempt to change state,
  this function will return.  The idea is that you use this when you want to initialize a process NOW.
  This will then return the value of the function you called!"
  (when (zero? func)
    (format 0 "attempting to run nullptr function!~%")
    (break!)
    )
  (rlet ((pp :reg r13 :type process))

    (let ((param-array (new 'stack-no-clear 'array 'uint64 6))
          )
      ;; copy params to the stack.

      (set! (-> param-array 0) (the uint64 a0))
      (set! (-> param-array 1) (the uint64 a1))
      (set! (-> param-array 2) (the uint64 a2))
      (set! (-> param-array 3) (the uint64 a3))
      (set! (-> param-array 4) (the uint64 a4))
      (set! (-> param-array 5) (the uint64 a5))

      (let* ((old-pp pp)
             (func-val (begin
                        ;; set the process
                        (set! pp obj)
                        ;; set us as initializing
                        (set! (-> pp status) 'initialize)
                        ;; run!
                        (the object (new 'stack 'catch-frame 'initialize func param-array))
                        )))
        ;; the function returned, either through a throw or through actually returning.
        ;; the status will give us a clue of what happened.
        (case (-> pp status)
          (('initialize)
           ;; we returned and didn't change status.
           (set! (-> pp status) 'initialize-dead)
           ;; this means we died, and we should be deactivated.
           (deactivate pp)
           )
          (('initialize-go)
           ;; we returned with a (suspend) or (go) ? not sure
           ;; either way, we're ready for next time!
           (set! (-> pp status) 'waiting-to-run)
           (when (eq? (-> pp pool type) dead-pool-heap)
             ;; we can shrink the heap now.
             (shrink-heap (the dead-pool-heap (-> pp pool)) pp)
             )
           )
          (else
           (format 0 "GOT UNKNOWN INIT: ~A~%" (-> pp status))
           )
          )
        ;; restore the old pp
        (set! pp old-pp)
        func-val
        )
      )
    )
  )

(defun set-to-run-bootstrap ()
  "This function is a clever hack.
   To reset a thread to running a new function, we stash the arguments as saved registers.
   These are then restored by thread-resume on the next run of the kernel.
   This stub remaps these saved registers to argument registers.
   It also creates a return trampoline to return-from-thread-dead, so if the main thread returns, the
   process is properly cleaned up by deactivate."
  (declare (asm-func none)
           ;;(print-asm)
           )

  (rlet ((s0 :reg rbx :type uint)
         (s1 :reg rbp :type uint)
         (s2 :reg r10 :type uint)
         (s3 :reg r11 :type uint)
         (s4 :reg r12 :type uint)
         (a0 :reg rdi :type uint)       ; ok
         (a1 :reg rsi :type uint)       ; ok
         (a2 :reg rdx :type uint)       ; ok
         (a3 :reg rcx :type uint)       ; ok
         (off :reg r15 :type uint)
         (a4 :reg r8 :type uint)
         (a5 :reg r9 :type uint)
         (temp :reg rax)
         )


    (.mov temp return-from-thread-dead)
    (.add temp off)
    (.push temp)

    ;; stack is 16 + 8 aligned now

    (.mov :color #f a0 s1)
    (.mov :color #f a1 s2)
    (.mov :color #f a2 s3)
    (.mov :color #f a3 s4)

    (.add :color #f s0 off)
    (.jr :color #f s0)

    (.add a4 a4)
    (.add a5 a5)
    )
  )
;; decomp deviation

(defun set-to-run ((thread cpu-thread) (func function) a0 a1 a2 a3 a4 a5)
  "Set the given thread to call the given function with the given arguments next time it resumes.
  Only for main threads.
  Once the function returns, the process deactivates."
  (let ((proc (-> thread process)))
    (set! (-> proc status) 'waiting-to-run)

    ;; we store arguments and the function to call in saved registers
    (set! (-> thread rreg 0) (the uint func))
    (set! (-> thread rreg 1) (the uint a0))
    (set! (-> thread rreg 2) (the uint a1))
    (set! (-> thread rreg 3) (the uint a2))
    (set! (-> thread rreg 4) (the uint a3))
    (set! (-> thread rreg 5) (the uint a4))
    (set! (-> thread rreg 6) (the uint a5))

    ;; and have the thread first call set-to-run-bootstrap, which will properly call
    ;; the function with the arguments and install a return trampoline for
    ;; deactivating and returning to the kernel on return.
    (set! (-> thread pc) (the pointer set-to-run-bootstrap))
    ;; reset sp.
    (set! (-> thread sp) (-> thread stack-top))
    )
  )

(defmethod deactivate process-tree ((obj process-tree))
  (none)
  )

;; The defstate macro isn't defined yet, so we do it manually.
(define dead-state
        (the (state process) (new 'static 'state
                                  :name 'dead-state
                                  :next #f
                                  :exit #f
                                  :code #f
                                  :trans #f
                                  :post #f
                                  :enter #f
                                  :event #f)))

(set! (-> dead-state code) (the (function none :behavior process) nothing))
(define entity-deactivate-handler (the-as (function process entity-actor none) nothing))

;; decomp deviation
(defmethod deactivate process ((obj process))
  "Kill a process."
  (with-pp
    ;; only if we're not already dead
    (when (!= (-> obj status) 'dead)
      ;; set our next-state to dead. We'll run the exit function of the current state, and it can look at this
      ;; to tell that process is being killed.
      (set! (-> obj next-state) dead-state)

      ;; clean up entity stuff.
      (if (-> obj entity)
          (entity-deactivate-handler obj (the-as entity-actor (-> obj entity)))
          )

      ;; clean up stack frames. This will run the exit function of the current state
      (let ((s5-0 pp))
        ;; set process pointer to the deactivating process, to allow deactivations from another process.
        (set! pp obj)
        (let ((s4-0 (-> pp stack-frame-top)))
          (while (the-as protect-frame s4-0)
            (case (-> s4-0 type)
                  ((protect-frame state)
                   ;; run exit function!
                   ((-> (the-as protect-frame s4-0) exit))
                   )
                  )
            (set! s4-0 (-> (the-as protect-frame s4-0) next))
            )
          )
        (set! pp s5-0)
        )

      ;; clean up connection/engine stuff
      (if (!= 0 (the uint process-disconnect))
          (process-disconnect obj)
          )

      ;; kill our children
      (let ((v1-12 (-> obj child)))
        (while v1-12
          (let ((s5-1 (-> v1-12 0 brother)))
            (deactivate (-> v1-12 0))
            (set! v1-12 s5-1)
            )
          )
        )

      ;; return process memory to the pool
      (return-process (-> obj pool) obj)

      ;; clear fields to avoid confusion
      (set! (-> obj state) #f)
      (set! (-> obj next-state) #f)
      (set! (-> obj entity) #f)
      (set! (-> obj pid) 0)

      ;; now we have to leave this function...
      (cond
        ;; if you deactivated yourself, sneak a 'dead into our status,
        ;; then go back to the kernel dispatcher immediately.
        ((= (-> *kernel-context* current-process) obj)
         (set! (-> obj status) 'dead)
         (abandon-thread)
         )
        ;; if you deactivated yourself while initializing, we should go back to
        ;; the place where initialize was called in another process, not all the way back to the kernel.
        ((= (-> obj status) 'initialize)
         (set! (-> obj status) 'dead)
         ;; the initialization code is protected in a catch block.
         (throw 'initialize #f)
         )
        )

      ;; if you deactivated somebody else, just return as normal
      (set! (-> obj status) 'dead)
      )
    0
    (none)
    )
  )
;; decomp deviation

;;;;;;;;;;;;;;;;;;;
;; Kernel globals
;;;;;;;;;;;;;;;;;;;

(kmemopen global "process-buffers")

;; set up the listener process to run functions sent from the REPL.
(let ((v0-43 (new 'global 'process "listener" 2048)))
  (set! *listener-process* v0-43)
  (let ((gp-0 v0-43))
    (set! (-> gp-0 status) 'ready)
    (set! (-> gp-0 pid) 1)
    (set! (-> gp-0 main-thread) (new 'process 'cpu-thread gp-0 'main 256 (&-> *dram-stack* 14336)))
    )
  )

;; an always dead process used as a placeholder
(define *null-process* (new 'global 'process "null" 16))
;; do we have visibility data? This will control warnings about actor memory
;; and choose which DGOs to load.
(define *vis-boot* #f)
;; the default clock
(define *kernel-clock* (new 'static 'clock))
;; fixed size dead-pools.
(define *16k-dead-pool* (new 'global 'dead-pool 2 #x4000 "*16k-dead-pool*"))
(define *8k-dead-pool* (new 'global 'dead-pool 2 8192 "*8k-dead-pool*"))
(define *4k-dead-pool* (new 'global 'dead-pool 4 4096 "*4k-dead-pool*"))
;; special dead pools
(define *target-dead-pool* (new 'global 'dead-pool 2 #xc000 "*target-dead-pool*"))
(define *camera-dead-pool* (new 'global 'dead-pool 7 4096 "*camera-dead-pool*"))
(define *camera-master-dead-pool* (new 'global 'dead-pool 1 8192 "*camera-master-dead-pool*"))
;; heap dead pools
(when *debug-segment*
  (define *debug-dead-pool* (new 'debug 'dead-pool-heap "*debug-dead-pool*" 768 #x100000))
  )
(define *nk-dead-pool* (new 'global 'dead-pool-heap "*nk-dead-pool*" PROCESS_HEAP_MAX PROCESS_HEAP_SIZE))
;; more special dead pools
(define *default-dead-pool* (the-as dead-pool *nk-dead-pool*))
(define *pickup-dead-pool* (the-as dead-pool *nk-dead-pool*))
(define *city-dead-pool* (new 'loading-level 'dead-pool-heap "*city-dead-pool*" 256 0))
(define *dead-pool-list* '(*4k-dead-pool*
                            *8k-dead-pool*
                            *16k-dead-pool*
                            *nk-dead-pool*
                            *target-dead-pool*
                            *camera-dead-pool*
                            *camera-master-dead-pool*
                            )
        )

;; root tree node for all active processes.
(define *active-pool* (new 'global 'process-tree "active-pool"))

;; categories within the active pool.
(change-parent (define *display-pool* (new 'global 'process-tree "display-pool")) *active-pool*)

(change-parent (define *camera-pool* (new 'global 'process-tree "camera-pool")) *active-pool*)
(set! (-> *camera-pool* mask) (process-mask freeze pause menu progress process-tree camera))

(change-parent (define *target-pool* (new 'global 'process-tree "target-pool")) *active-pool*)
(set! (-> *target-pool* mask) (process-mask freeze pause menu progress process-tree))

(change-parent (define *entity-pool* (new 'global 'process-tree "entity-pool")) *active-pool*)
(set! (-> *entity-pool* mask) (process-mask freeze pause menu progress process-tree entity))

(change-parent (define *mid-pool* (new 'global 'process-tree "mid-pool")) *active-pool*)

(change-parent (define *pusher-pool* (new 'global 'process-tree "pusher-pool")) *active-pool*)
(set! (-> *pusher-pool* mask) (process-mask freeze pause menu progress process-tree entity))

(change-parent (define *bg-pool* (new 'global 'process-tree "bg-pool")) *active-pool*)
(set! (-> *bg-pool* mask) (process-mask freeze pause menu progress process-tree))

(change-parent (define *default-pool* (new 'global 'process-tree "default-pool")) *active-pool*)
(set! (-> *default-pool* mask) (process-mask freeze pause menu progress process-tree))

(kmemclose)

(defmacro ps (&key (detail #f))
  `(inspect-process-tree *active-pool* 0 0 ,detail)
  )