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

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

;; This file has a large number of differences from the original.

;; This is the GOAL kernel, which is responsible for handling processes.

(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))
(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
(define *use-old-listener-print* #f)
(define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*)))
(define *irx-version* (the-as binteger #x200000))

(define *kernel-boot-mode* 'listener)
(define *kernel-boot-level* #f)

(define *deci-count* 0)

(define *last-loado-length* 0)
(define *last-loado-global-usage* 0)
(define *last-loado-debug-usage* 0)

;;;;;;;;;;;;;;;;;;;;
;; relocate method
;;;;;;;;;;;;;;;;;;;;

;; All children of process, and all objects allocated on a process heap should support a
;; `relocate` method. This method is used by the kernel to move the process (and its heap)
;; in memory. For this reason, `relocate` is a method available on all objects.

(defmethod relocate ((this object) (offset int))
  "Most general relocate method."
  this
  )


;;;;;;;;;;;;;;;;;;;
;; package system
;;;;;;;;;;;;;;;;;;;

;; simple system to load packages by name. Currently, package loading is done at boot,
;; by the C Kernel, before the GOAL kernel is running. However, this GOAL version can load
;; kernel packages as well, if the C Kernel is started without DiskBoot set, for example.

;; currently loaded packages.
(define *kernel-packages* '())

(defun load-package ((package-name string) (heap kheap))
  "If not already loaded, do a blocking dgo-load to load the given CGO."
  (when (not (nmember package-name *kernel-packages*))
    (kmemopen global package-name)
    (dgo-load
      package-name
      heap
      (link-flag output-load-msg output-load-true-msg execute-login print-login)
      #x200000
      )
    (set! *kernel-packages* (cons package-name *kernel-packages*))
    (kmemclose)
    *kernel-packages*
    )
  )

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


;;;;;;;;;;;;;;;
;; context
;;;;;;;;;;;;;;;

;; The context stores the relatively simple state of the kernel.

(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 stack for running user code.
(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)))
(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE))

;; The kernel can also run code using the scratchpad as the stack.
;; This is only possible for processes that don't use the scratchpad otherwise.
(set! (-> *kernel-context* fast-stack-top) (the-as pointer #x70004000))

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

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

;; the playstation 2 had 16 kB of very fast memory called the "scratchpad". It was as fast as the L1 cache.
;; It was mapped at address 0x7000000. We provide a "fake" scratchpad. There are a few hacks here:
;; - we define a macro to check if an address is "in scratch" or not. The game uses this check.
;; - we make sure the scratchpad is 64 kB aligned. There is some fancy double-buffer toggling code that
;;   relies on bit patterns in the address, and the base address must be 64 kB aligned.
;; - the scratchpad size is increased to 64 kB, to increase the maximum stack size.

;; og:preserve-this
;; DECOMP DEVIATION
(#cond
  (PC_PORT
  (define *canary-4* (the-as (pointer uint64) (malloc 'global 8)))
  ;; 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.
  (define *fake-scratchpad-size* (* 128 1024))
  (let* ((mem (new 'global 'array 'uint8 (* 2 *fake-scratchpad-size*)))
         )
      (define *fake-scratchpad-alloc* mem)
      (define *fake-scratchpad-data* (the pointer (align-n mem *fake-scratchpad-size*)))
    )

  ;; 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*
    )
  (defmacro scratchpad-end ()
    "Get the start of the scratchpad. At least 64kB aligned."
    `(&+ (scratchpad-start) *fake-scratchpad-size*)
    )
  )
  (else
    (defmacro scratchpad-start ()
      #x70000000
      )
    (defmacro scratchpad-end ()
      "Get the start of the scratchpad. At least 64kB aligned."
      `(&+ (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))
     )
  )

;;;;;;;;;;;
;; thread
;;;;;;;;;;;

;; A "GOAL" thread comes in two varieties:
;; A "temporary" thread, for running a single function, which returns immediately.
;;  in this case, the thread is basically a helper structure to handle the kernel -> user code switch.
;; A "main" thread, for running the main code of a process.
;;  in this case, the thread is responsible for suspending and resuming this process's code.
;;  GOAL main threads do cooperative multi-tasking.

(defmethod delete ((this thread))
  "Clean up a temporary thread. This should only be called on a temporary thread."
  (when (= this (-> this process main-thread))
    (break!) ;; abort if we delete a main thread.
    0
    )
  ;; restore previous thread.
  (set! (-> this process top-thread) (the-as cpu-thread (-> this previous)))
  0
  (none)
  )

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

(defmethod stack-size-set! ((this thread) (size-bytes int))
  "Adjust the size of the stack that can be stored during a suspend. Must be called before any process allocations."
  (let ((a2-0 (-> this process)))
    (cond
      ((!= this (-> 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)
       )
      ((= (-> this stack-size) size-bytes)
       )
      ((= (-> a2-0 heap-cur) (+ (+ (-> this stack-size) -4 (-> this type size)) (the-as int this)))
       (set! (-> a2-0 heap-cur) (the-as pointer (+ (+ size-bytes -4 (-> this type size)) (the-as int this))))
       (set! (-> this stack-size) size-bytes)
       )
      (else
        (format 0 "ERROR: illegal attempt change stack size of ~A after more heap allocation has occured.~%" a2-0)
        )
      )
    )
  0
  (none)
  )

(defmethod new cpu-thread ((allocation symbol) (type-to-make type) (proc process) (name symbol) (stack-size int) (stack-top pointer))
  "Allocate a thread. If there is already a top-thread for this process, assume this is a temporary thread, and allocate on the bottom of the stack."
  (let ((v0-0 (cond
                ((-> proc top-thread)
                 ;; stash this at the "bottom" of the stack. They finally fixed this for jak 3!
                 ;; for non-scratch stacks, it's actually at the bottom now.
                 ;; for scratch stacks, it's still halfway down... but maybe this lets you use the
                 ;; first ~8 kB of scratch still?
                 (+ (+ (if (in-scratchpad? stack-top) ;; (logtest? #x70000000 stack-top)
                           (- PROCESS_STACK_SIZE ) ;; -7168
                           (- DPROCESS_STACK_SIZE) ;; -14336
                           )
                       4
                       )
                    (the-as int stack-top)
                    )
                 )
                (else
                  (let ((v1-6 (logand -16 (&+ (-> proc heap-cur) 15))))
                    (set! (-> proc heap-cur) (&+ (&+ v1-6 (-> type-to-make size)) stack-size))
                    (&+ v1-6 4)
                    )
                  )
                )
              )
        )
    (set! (-> (the-as cpu-thread v0-0) type) type-to-make)
    (set! (-> (the-as cpu-thread v0-0) name) name)
    (set! (-> (the-as cpu-thread v0-0) process) proc)
    (set! (-> (the-as cpu-thread v0-0) sp) stack-top)
    (set! (-> (the-as cpu-thread v0-0) stack-top) stack-top)
    (set! (-> (the-as cpu-thread v0-0) previous) (-> proc top-thread))
    (set! (-> proc top-thread) (the-as cpu-thread v0-0))
    (set! (-> (the-as cpu-thread v0-0) suspend-hook) (method-of-object (the-as cpu-thread v0-0) thread-suspend))
    (set! (-> (the-as cpu-thread v0-0) resume-hook) (method-of-object (the-as cpu-thread v0-0) thread-resume))
    (set! (-> (the-as cpu-thread v0-0) stack-size) stack-size)
    (the-as cpu-thread v0-0)
    )
  )

(defmethod asize-of ((this cpu-thread))
  (the-as int (+ (-> this type size) (-> this stack-size)))
  )

(defbehavior remove-exit process ()
  "Remove the top stack frame. If you have no other stack frames, you can use this before a `go`
   to skip the `exit` of the state you are currently in."
  (if (-> self stack-frame-top)
      (set! (-> self stack-frame-top) (-> self stack-frame-top next))
      )
  0
  (none)
  )

(defun-debug stream<-process-mask ((arg0 object) (arg1 process-mask))
  "Print out the process-mask as a human readable string."
  (bit-enum->string process-mask arg1 arg0)
  arg1
  )

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

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

(defmethod new process-tree ((allocation symbol) (type-to-make type) (name string))
  "Allocate a process-tree with the kernel clock."
  (let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> v0-0 name) name)
    (set! (-> v0-0 mask) (process-mask process-tree))
    (set! (-> v0-0 clock) *kernel-clock*)
    (+! (-> v0-0 clock ref-count) 1)
    (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 ((this process-tree))
  (format #t "[~8x] ~A~%" this (-> this type))
  (format #t "~Tname: ~S~%" (-> this name))
  (format #t "~1Tmask: #x~X : (process-mask " (-> this mask))
  (stream<-process-mask #t (-> this mask))
  (format #t ")~%")
  (format #t "~Tclock: ~A~%" (-> this clock))
  (format #t "~Tparent: ~A~%" (ppointer->process (-> this parent)))
  (format #t "~Tbrother: ~A~%" (ppointer->process (-> this brother)))
  (format #t "~Tchild: ~A~%" (ppointer->process (-> this child)))
  this
  )

(defmethod new process ((allocation symbol) (type-to-make type) (name string) (process-heap-size int))
  "Allocate a process, set up process heap, self/ppointer, clock."
  (let ((v0-0 (if (logtest? (the-as int allocation) 1)
                  (object-new allocation type-to-make (the-as int (+ (-> process size) process-heap-size)))
                  (+ (the-as int allocation) 4)
                  )
              )
        )
    (set! (-> (the-as process v0-0) name) name)
    (set! (-> (the-as process v0-0) clock) *kernel-clock*)
    (+! (-> (the-as process v0-0) clock ref-count) 1)
    (set! (-> (the-as process v0-0) status) 'dead)
    (set! (-> (the-as process v0-0) pid) 0)
    (set! (-> (the-as process v0-0) pool) #f)
    (set! (-> (the-as process v0-0) allocated-length) process-heap-size)
    (set! (-> (the-as process v0-0) top-thread) #f)
    (set! (-> (the-as process v0-0) main-thread) #f)
    (let ((v1-9 (-> (the-as process v0-0) stack)))
      (set! (-> (the-as process v0-0) heap-cur) v1-9)
      (set! (-> (the-as process v0-0) heap-base) v1-9)
      )
    (set! (-> (the-as process v0-0) heap-top)
          (&-> (the-as process v0-0) stack (-> (the-as process v0-0) allocated-length))
          )
    (set! (-> (the-as process v0-0) stack-frame-top) (the-as stack-frame (-> (the-as process v0-0) heap-top)))
    (set! (-> (the-as process v0-0) stack-frame-top) #f)
    (set! (-> (the-as process v0-0) state) #f)
    (set! (-> (the-as process v0-0) next-state) #f)
    (set! (-> (the-as process v0-0) prev-state) #f)
    (set! (-> (the-as process v0-0) state-stack) #f)
    (set! (-> (the-as process v0-0) entity) #f)
    (set! (-> (the-as process v0-0) level) #f)
    (set! (-> (the-as process v0-0) trans-hook) #f)
    (set! (-> (the-as process v0-0) post-hook) #f)
    (set! (-> (the-as process v0-0) event-hook) #f)
    (set! (-> (the-as process v0-0) parent) (the-as (pointer process-tree) #f))
    (set! (-> (the-as process v0-0) brother) (the-as (pointer process-tree) #f))
    (set! (-> (the-as process v0-0) child) (the-as (pointer process-tree) #f))
    (set! (-> (the-as process v0-0) self) (the-as process v0-0))
    (set! (-> (the-as process v0-0) ppointer) (&-> (the-as process v0-0) self))
    (the-as process v0-0)
    )
  )

(defun inspect-process-heap ((proc process))
  "Call the inspect method on every object in the process heap."
  (let ((s5-0 (the-as object (&+ (-> proc heap-base) 4))))
    (while (< (the-as int s5-0) (the-as int (-> proc heap-cur)))
      (inspect (the-as basic s5-0))
      (set! s5-0 (&+ (the-as pointer s5-0) (logand -16 (+ (asize-of (the-as basic s5-0)) 15))))
      )
    )
  #f
  )

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

(defmethod asize-of ((this process))
  (the-as int (+ (-> process size) (-> this allocated-length)))
  )

(defmethod print ((this process))
  (cond
    ((and (-> this top-thread) (!= (-> this status) 'dead))
     (format #t "#<~A ~S ~A :state ~S " (-> this type) (-> this name) (-> this status) (if (-> this state)
                                                                                           (-> this state name)
                                                                                           )
             )
     (format
       #t
       ":stack ~D/~D :heap ~D/~D @ #x~X>"
       (&- (-> this top-thread stack-top) (the-as uint (-> this top-thread sp)))
       (-> this main-thread stack-size)
       (- (-> this allocated-length) (&- (-> this heap-top) (the-as uint (-> this heap-cur))))
       (-> this allocated-length)
       this
       )
     )
    (else
      (format
        #t
        "#<~A ~S ~A :state ~S @ #x~X"
        (-> this type)
        (-> this name)
        (-> this status)
        (if (-> this state)
            (-> this state name)
            )
        this
        )
      )
    )
  this
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 ((this 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 (-> this process))
    ;; mark the process as running and set its top thread
    (set! (-> pp status) 'running)
    (set! (-> pp top-thread) (the cpu-thread this))

    ;; 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 (-> this 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 ((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 ((this :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! (-> this pc) (the pointer temp))

    ;; convert our stack pointer to a GOAL address
    (.sub sp off)
    ;; store in thread.
    (set! (-> this sp) (the pointer sp))

    ;; back up registers
    (.mov :color #f temp s0)
    (set! (-> this rreg 0) temp)
    (.mov :color #f temp s1)
    (set! (-> this rreg 1) temp)
    (.mov :color #f temp s2)
    (set! (-> this rreg 2) temp)
    (.mov :color #f temp s3)
    (set! (-> this rreg 3) temp)
    (.mov :color #f temp s4)
    (set! (-> this rreg 4) temp)

    ;; back up fprs
    (.mov :color #f temp xmm8)
    (set! (-> this freg 0) (the-as float temp))
    (.mov :color #f temp xmm9)
    (set! (-> this freg 1) (the-as float temp))
    (.mov :color #f temp xmm10)
    (set! (-> this freg 2) (the-as float temp))
    (.mov :color #f temp xmm11)
    (set! (-> this freg 3) (the-as float temp))
    (.mov :color #f temp xmm12)
    (set! (-> this freg 4) (the-as float temp))
    (.mov :color #f temp xmm13)
    (set! (-> this freg 5) (the-as float temp))
    (.mov :color #f temp xmm14)
    (set! (-> this freg 6) (the-as float temp))
    (.mov :color #f temp xmm15)
    (set! (-> this freg 7) (the-as float temp))

    ;; get our process
    (let ((proc (-> this process)))
      (when (> (process-stack-used proc) (-> this 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) (-> this stack-top)))
            (save (&+ (the (pointer uint64) (-> this stack)) (-> this 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! this (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 ((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 ((this :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! this thread-to-resume)

    ;; set stack pointer for the thread. leave it as a GOAL pointer for now..
    (set! sp (the uint (-> this sp)))

    ;; restore the stack (sp is a GOAL pointer)
    (let ((cur (the (pointer uint64) (-> this stack-top)))
          (restore (&+ (the (pointer uint64) (-> this stack)) (-> this 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! (-> (-> this process) top-thread) this)
    (set! (-> (-> this process) status) 'running)

    ;; restore reg
    (set! temp (-> this rreg 0))
    (.mov :color #f s0 temp)
    (set! temp (-> this rreg 1))
    (.mov :color #f s1 temp)
    (set! temp (-> this rreg 2))
    (.mov :color #f s2 temp)
    (set! temp (-> this rreg 3))
    (.mov :color #f s3 temp)
    (set! temp (-> this rreg 4))
    (.mov :color #f s4 temp)
    (set! temp-float (-> this freg 0))
    (.mov :color #f xmm8 temp-float)
    (set! temp-float (-> this freg 1))
    (.mov :color #f xmm9 temp-float)
    (set! temp-float (-> this freg 2))
    (.mov :color #f xmm10 temp-float)
    (set! temp-float (-> this freg 3))
    (.mov :color #f xmm11 temp-float)
    (set! temp-float (-> this freg 4))
    (.mov :color #f xmm12 temp-float)
    (set! temp-float (-> this freg 5))
    (.mov :color #f xmm13 temp-float)
    (set! temp-float (-> this freg 6))
    (.mov :color #f xmm14 temp-float)
    (set! temp-float (-> this 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 (-> this rreg 5))
    (.mov a4 temp)
    (set! temp (-> this rreg 6))
    (.mov a5 temp)

    ;; get the resume address
    (set! temp (the uint (-> this pc)))
    (.add temp off)

    ;; setup the process
    (set! this (the cpu-thread (-> this process)))
    ;; resume!
    (.jr temp)
    (.add a4 a4)
    (.add a5 a5)
    )
  (none)
  )

(defmethod new dead-pool ((allocation symbol) (type-to-make type) (num-proc int) (process-size int) (name string))
  "Allocate a dead pool and set up dead processes"
  (let ((s3-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> s3-0 name) name)
    (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 num-proc)
      (let ((s1-0 (-> s3-0 child))
            (v1-5 ((method-of-type process new) allocation process "dead" process-size))
            )
        (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
    )
  )

(defmethod get-process ((this dead-pool) (proc-type type) (proc-size int) (unk object))
  "Allocate a process from the pool, or #f if it fails."
  (let ((s4-0 (the-as object (-> this child))))
    (when (and (not (the-as (pointer process-tree) s4-0)) *debug-segment* (!= this *debug-dead-pool*))
      (set! s4-0 (get-process *debug-dead-pool* proc-type proc-size unk))
      (if (the-as process s4-0)
          (format
            0
            "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
            proc-type
            #f ;; bug! (ppointer->process (the-as process s4-0))
            (-> this name)
            )
          )
      (break!) ;; bug in original game with process vs pointer process.
      )
    (cond
      (s4-0
        (set! (-> (the-as (pointer process) s4-0) 0 type) proc-type)
        (-> (the-as (pointer process) s4-0) 0)
        )
      (else
        (format
          0
          "WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
          proc-type
          (ppointer->process (the-as (pointer process) s4-0))
          (-> this name)
          )
        (the-as process #f)
        )
      )
    )
  )

(defmethod return-process ((this dead-pool) (proc process))
  "Return a process to the pool."
  (change-parent proc this)
  0
  (none)
  )

(defmethod new dead-pool-heap ((allocation symbol) (type-to-make type) (name string) (max-num-proc int) (heap-size int))
  "Allocate and initialize a dead-pool-heap."
  (let ((s2-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* 12 max-num-proc))))))
    (set! (-> s2-0 name) name)
    (set! (-> s2-0 mask) (process-mask process-tree))
    (set! (-> s2-0 allocated-length) max-num-proc)
    (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 heap-size)
    s2-0
    )
  )

(defmethod init ((this dead-pool-heap) (allocation symbol) (heap-size int))
  "Allocate memory for processes and init records."
  (countdown (v1-0 (-> this allocated-length))
    (let ((a0-4 (-> this process-list v1-0)))
      (set! (-> a0-4 process) *null-process*)
      (set! (-> a0-4 next) (-> this process-list (+ v1-0 1)))
      )
    )
  (set! (-> this dead-list next) (the-as dead-pool-heap-rec (-> this process-list)))
  (set! (-> this alive-list process) #f)
  (set! (-> this process-list (+ (-> this allocated-length) -1) next) #f)
  (set! (-> this alive-list prev) (-> this alive-list))
  (set! (-> this alive-list next) #f)
  (set! (-> this alive-list process) #f)
  (set! (-> this first-gap) (-> this alive-list))
  (set! (-> this first-shrink) #f)
  (cond
    ((zero? heap-size)
     (set! (-> this heap base) (the-as pointer 0))
     (set! (-> this heap current) (the-as pointer 0))
     (set! (-> this heap top) (the-as pointer 0))
     (set! (-> this heap top-base) (the-as pointer 0))
     0
     )
    (else
      (set! (-> this heap base) (malloc allocation heap-size))
      (set! (-> this heap current) (-> this heap base))
      (set! (-> this heap top) (&+ (-> this heap base) heap-size))
      (set! (-> this heap top-base) (-> this heap top))
      )
    )
  (none)
  )

(defmethod gap-location ((this dead-pool-heap) (rec dead-pool-heap-rec))
  "Get pointer to gap (possibly zero size) after the given process"
  (the-as
    pointer
    (if (-> rec process)
        (+ (+ (-> rec process allocated-length) -4 (-> process size)) (the-as int (-> rec process)))
        (-> this heap base)
        )
    )
  )

(defmethod gap-size ((this dead-pool-heap) (first-rec dead-pool-heap-rec))
  "Get the size of the gap (possibly zero) after the given process. Use #f for the gap at the start of the pool memory."
  (cond
    ((-> first-rec process)
     (let ((v1-3
             (&+ (&+ (the-as pointer (-> first-rec process)) (-> process size)) (-> first-rec process allocated-length))
             )
           )
       (if (-> first-rec next)
           (&- (the-as pointer (-> first-rec next process)) (the-as uint v1-3))
           (&- (-> this heap top) (the-as uint (&+ v1-3 4)))
           )
       )
     )
    ((-> first-rec next)
     (&- (the-as pointer (-> first-rec next process)) (the-as uint (&+ (-> this heap base) 4)))
     )
    (else
      (&- (-> this heap top) (the-as uint (-> this heap base)))
      )
    )
  )

(defmethod find-gap ((this dead-pool-heap) (first-rec dead-pool-heap-rec))
  "Find the first process with a nonzero gap after it, after the given process."
  (while (and (-> first-rec next) (zero? (gap-size this first-rec)))
    (set! first-rec (-> first-rec next))
    )
  first-rec
  )

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

(defmethod asize-of ((this dead-pool-heap))
  (the-as int (+ (-> this type size) (* 12 (-> this allocated-length))))
  )

(defmethod memory-used ((this dead-pool-heap))
  "Get the total memory used. Memory in between processes that is not used by a process is considered used."
  (if (-> this alive-list prev)
      (- (memory-total this) (gap-size this (-> this alive-list prev)))
      0
      )
  )

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

(defmethod memory-free ((this dead-pool-heap))
  "Get the size of the unused part of the heap."
  (let ((v1-0 (-> this heap top)))
    (if (-> this alive-list prev)
        (gap-size this (-> this alive-list prev))
        (&- v1-0 (the-as uint (-> this heap base)))
        )
    )
  )

(defmethod compact-time ((this dead-pool-heap))
  "Get the compaction time (never set)."
  (-> this compact-time)
  )

(defmethod find-gap-by-size ((this dead-pool-heap) (size int))
  "Find the first gap with a size at least this big"
  (let ((gp-0 (-> this first-gap)))
    (while (and gp-0 (< (gap-size this gp-0) size))
      (set! gp-0 (-> gp-0 next))
      )
    gp-0
    )
  )

(defmethod get-process ((this dead-pool-heap) (proc-type type) (proc-size int) (unk object))
  "Allocate a process from the pool, or #f if it fails."
  (let ((s3-0 (-> this dead-list next))
        (s4-0 (the-as process #f))
        )
    (let ((s1-0 (find-gap-by-size this (the-as int (+ (-> process size) proc-size)))))
      (cond
        ((and s3-0 s1-0 (nonzero? (-> this heap base)))
         (set! (-> this dead-list next) (-> s3-0 next))
         (let ((v1-6 (-> s1-0 next)))
           (set! (-> s1-0 next) s3-0)
           (set! (-> s3-0 next) v1-6)
           (if v1-6
               (set! (-> v1-6 prev) s3-0)
               )
           )
         (set! (-> s3-0 prev) s1-0)
         (if (= s1-0 (-> this alive-list prev))
             (set! (-> this alive-list prev) s3-0)
             )
         (let ((a0-5 (gap-location this s1-0)))
           (set! s4-0 ((method-of-type process new) (the-as symbol a0-5) process "process" proc-size))
           )
         (set! (-> s3-0 process) s4-0)
         (set! (-> s4-0 ppointer) (&-> s3-0 process))
         (if (= (-> this first-gap) s1-0)
             (set! (-> this first-gap) (find-gap this s3-0))
             )
         (if (or (not (-> this first-shrink)) (< (the-as int s4-0) (the-as int (-> this first-shrink process))))
             (set! (-> this first-shrink) s3-0)
             )
         (set! (-> s4-0 parent) (-> this ppointer))
         (set! (-> s4-0 pool) this)
         (set! (-> this child) (&-> s3-0 process))
         )
        (else
          (when (and *debug-segment* (!= this *debug-dead-pool*))
            (set! s4-0 (get-process *debug-dead-pool* proc-type proc-size unk))
            (if (and s4-0 *vis-boot*)
                (format
                  0
                  "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
                  proc-type
                  s4-0
                  (-> this name)
                  )
                )
            0
            )
          )
        )
      )
    (if s4-0
        (set! (-> s4-0 type) proc-type)
        (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" proc-type s4-0 (-> this name))
        )
    s4-0
    )
  )

(defmethod return-process ((this dead-pool-heap) (proc process))
  "Return a process to the pool."
  (if (!= this (-> proc pool))
      (format 0 "ERROR: process ~A does not belong to dead-pool-heap ~A.~%" proc this)
      )
  (change-parent proc this)
  (set! (-> this child) (the-as (pointer process-tree) #f))
  (let ((s5-1 (-> proc ppointer)))
    (if (or (= (-> this first-gap) s5-1) (< (the-as int (gap-location this (the-as dead-pool-heap-rec s5-1)))
                                            (the-as int (gap-location this (-> this first-gap)))
                                            )
            )
        (set! (-> this first-gap) (the-as dead-pool-heap-rec (-> s5-1 1)))
        )
    (when (= (-> this first-shrink) s5-1)
      (set! (-> this first-shrink) (the-as dead-pool-heap-rec (-> s5-1 1)))
      (if (not (-> this first-shrink process))
          (set! (-> this first-shrink) #f)
          )
      )
    (set! (-> s5-1 1 clock) (the-as clock (-> s5-1 2)))
    (if (-> s5-1 2)
        (set! (-> s5-1 2 mask) (the-as process-mask (-> s5-1 1)))
        (set! (-> this alive-list prev) (the-as dead-pool-heap-rec (-> s5-1 1)))
        )
    (set! (-> s5-1 2) (the-as process (-> this dead-list next)))
    (set! (-> this dead-list next) (the-as dead-pool-heap-rec s5-1))
    (set! (-> s5-1 0) *null-process*)
    )
  0
  (none)
  )

(defmethod shrink-heap ((this dead-pool-heap) (proc process))
  "Shrink the heap of a process, allowing the dead pool heap to later reclaim the memory during a compact."
  (when proc
    (let ((s5-0 (-> proc ppointer)))
      (when (not (or (logtest? (-> proc mask) (process-mask heap-shrunk))
                     (and (not (-> proc next-state)) (not (-> proc state)))
                     )
                 )
        (set! (-> proc allocated-length) (&- (-> proc heap-cur) (the-as uint (-> proc stack))))
        (set! (-> proc heap-top) (&-> proc stack (-> proc allocated-length)))
        (if (< (the-as int proc) (the-as int (gap-location this (-> this first-gap))))
            (set! (-> this first-gap) (find-gap this (the-as dead-pool-heap-rec s5-0)))
            )
        (logior! (-> proc mask) (process-mask heap-shrunk))
        )
      (if (= (-> this first-shrink) s5-0)
          (set! (-> this first-shrink) (the-as dead-pool-heap-rec (-> s5-0 2)))
          )
      )
    )
  this
  )

(define-extern *nk-dead-pool* dead-pool-heap)

(defmethod compact ((this dead-pool-heap) (compact-count int))
  "Relocate process in memory to remove gaps, increasing free memory for this dead-pool-heap."
  (if (zero? (-> this heap base))
      (return 0)
      )
  (let* ((s4-0 (memory-free this))
         (v1-5 (memory-total this))
         (f0-2 (/ (the float s4-0) (the float v1-5)))
         )
    (cond
      ((< f0-2 0.1)
       (set! compact-count 1000)
       (if (and *debug-segment* (-> *kernel-context* low-memory-message))
           (format
             *stdcon*
             "~3LLow Actor Memory (free ~,,0fK/~,,0fK)~0L~%"
             (* 0.0009765625 (the float (memory-free *nk-dead-pool*)))
             (* 0.0009765625 (the float (memory-total *nk-dead-pool*)))
             )
           )
       )
      ((< f0-2 0.2)
       (set! compact-count (* compact-count 4))
       )
      ((< f0-2 0.3)
       (set! compact-count (* compact-count 2))
       )
      )
    )
  (set! (-> this compact-count-targ) (the-as uint compact-count))
  (set! (-> this compact-count) (the-as uint 0))
  (while (nonzero? compact-count)
    (+! compact-count -1)
    (let ((v1-25 (-> this first-shrink)))
      (when (not v1-25)
        (set! v1-25 (-> this alive-list next))
        (set! (-> this first-shrink) v1-25)
        )
      (if v1-25
          (shrink-heap this (-> v1-25 process))
          )
      )
    (let ((s4-2 (-> this first-gap)))
      (when (-> s4-2 next)
        (let ((s3-1 (-> s4-2 next process))
              (s2-1 (gap-size this s4-2))
              )
          (when (nonzero? s2-1)
            (when (< s2-1 0)
              (break!)
              0
              )
            (shrink-heap this s3-1)
            (relocate s3-1 (- s2-1))
            (set! (-> this first-gap) (find-gap this s4-2))
            (+! (-> this compact-count) 1)
            )
          )
        )
      )
    )
  0
  (none)
  )

(defmethod churn ((this dead-pool-heap) (count int))
  "Relocate process in memory, to trigger memory bugs related to process relocation."
  (while (nonzero? count)
    (+! count -1)
    (let ((s4-0 (-> this alive-list next)))
      (when s4-0
        (if (or (= (-> this first-gap) s4-0)
                (< (the-as int (gap-location this s4-0)) (the-as int (gap-location this (-> this first-gap))))
                )
            (set! (-> this first-gap) (-> s4-0 prev))
            )
        (when (= (-> this first-shrink) s4-0)
          (set! (-> this first-shrink) (-> s4-0 prev))
          (if (not (-> this first-shrink process))
              (set! (-> this first-shrink) #f)
              )
          )
        (set! (-> s4-0 prev next) (-> s4-0 next))
        (if (-> s4-0 next)
            (set! (-> s4-0 next prev) (-> s4-0 prev))
            (set! (-> this alive-list prev) (-> s4-0 prev))
            )
        (let ((a1-3 (-> this 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! (-> this alive-list prev) s4-0)
          (set! (-> s4-0 process)
                (relocate (-> s4-0 process) (&- (gap-location this a1-3) (the-as uint (&-> (-> s4-0 process) type))))
                )
          )
        )
      )
    )
  0
  (none)
  )

(defun method-state ((typ type) (state-name symbol))
  "Get a virtual state from this type by name."
  (dotimes (v1-0 (the-as int (-> typ allocated-length)))
    (let ((a2-2 (the-as basic (-> typ 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) state-name)
               )
          (return (the-as state a2-2))
          )
      )
    )
  (the-as state #f)
  )

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

(define *global-search-name* (the-as basic #f))
(define *global-search-count* 0)

(defun process-by-name ((process-name string) (tree process-tree))
  "Find the first process with the given name in the process-tree."
  (set! *global-search-name* process-name)
  (search-process-tree
    tree
    (lambda ((arg0 process)) (string= (-> arg0 name) (the-as string *global-search-name*)))
    )
  )

(defun process-not-name ((name string) (tree process-tree))
  "Find the first process without the given name in the process-tree."
  (set! *global-search-name* name)
  (search-process-tree
    tree
    (lambda ((arg0 process)) (not (string= (-> arg0 name) (the-as string *global-search-name*))))
    )
  )

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

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

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

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

(defun kill-not-type ((typ type) (tree process-tree))
  "Kill all processes, except ones with the exact type."
  (local-vars (a0-1 process))
  (set! *global-search-name* typ)
  (while (begin
           (set! a0-1 (search-process-tree tree (lambda ((arg0 process)) (!= (-> arg0 type) *global-search-name*))))
           a0-1
           )
    (deactivate a0-1)
    )
  #f
  )

(defun kill-by-type-inherited ((typ type) (tree process-tree))
  "Kill all processes, except ones that inherit from the given type."
  (local-vars (a0-1 process))
  (set! *global-search-name* typ)
  (while (begin
           (set! a0-1
                 (search-process-tree tree (lambda ((arg0 process)) (type? arg0 (the-as type *global-search-name*))))
                 )
           a0-1
           )
    (deactivate a0-1)
    )
  #f
  )

(defmethod run-logic? ((this process-tree))
  "Should this process be run? Checked by execute-process-tree."
  #f
  )

(defmethod run-logic? ((this process))
  "Should this process be run? Checked by execute-process-tree."
  #t
  )

(defun iterate-process-tree ((tree process-tree) (callback (function object object)) (context kernel-context))
  "Call a function on each not-dead process in the tree."
  (let ((s4-0 (or (logtest? (-> tree mask) (process-mask process-tree)) (callback tree))))
    (cond
      ((= s4-0 'dead)
       )
      (else
        (let ((v1-4 (-> tree child)))
          (while v1-4
            (let ((s3-1 (-> v1-4 0 brother)))
              (iterate-process-tree (-> v1-4 0) callback context)
              (set! v1-4 s3-1)
              )
            )
          )
        )
      )
    s4-0
    )
  )

(defun execute-process-tree ((tree process-tree) (callback (function object object)) (context kernel-context))
  "Iterate over all process, calling the run callback on each, if they should run."
  (logclear! (-> tree mask) (process-mask kernel-run))
  (let ((s3-0 (or (logtest? (-> tree mask) (process-mask process-tree))
                  (not (and (not (logtest? (-> context prevent-from-run) (-> tree mask))) (run-logic? tree)))
                  (begin (logior! (-> tree mask) (process-mask kernel-run)) (callback tree))
                  )
              )
        )
    (cond
      ((= s3-0 'dead)
       )
      (else
        (let ((v1-12 (-> tree child)))
          (while v1-12
            (let ((s4-1 (-> v1-12 0 brother)))
              (execute-process-tree (-> v1-12 0) callback context)
              (set! v1-12 s4-1)
              )
            )
          )
        )
      )
    s3-0
    )
  )

(defun search-process-tree ((tree process-tree) (callback (function process-tree object)))
  "Return the first function in the process-tree which the callback returns #t on."
  (when (not (logtest? (-> tree mask) (process-mask process-tree)))
    (if (callback tree)
        (return (the-as process tree))
        )
    )
  (let ((v1-5 (-> tree child)))
    (while v1-5
      (let ((s5-1 (-> v1-5 0 brother)))
        (let ((v1-6 (search-process-tree (-> v1-5 0) callback)))
          (if v1-6
              (return v1-6)
              )
          )
        (set! v1-5 s5-1)
        )
      )
    )
  (the-as process #f)
  )

(defun kernel-dispatcher ()
  "Run the GOAL kernel! Runs the function from the listener (if there is one), then all processes"

  (profiler-instant-event "ROOT")

  (when *listener-function*
    (set! *enable-method-set* (+ *enable-method-set* 1))
    (let ((t1-0 (reset-and-call (-> *listener-process* main-thread) *listener-function*)))
      ;; changed here.
      (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))
    0
    )
  (execute-process-tree
    *active-pool*
    (lambda ((arg0 process))
      ;; (+! (-> *canary-1*) 1)
      ;; (+! (-> *canary-2*) 1)
      ;; (+! (-> *canary-3*) 1)
      ;; (+! (-> *canary-4*) 1)
      (let ((s5-0 *kernel-context*))
        (case (-> arg0 status)
          (('waiting-to-run 'suspended)
           (set! (-> s5-0 current-process) arg0)
           (cond
             ((logtest? (-> arg0 mask) (process-mask pause))
              (set! *stdcon* *stdcon1*)
              (set! *debug-draw-pauseable* #t)
              )
             (else
               (set! *stdcon* *stdcon0*)
               (set! *debug-draw-pauseable* #f)
               )
             )
           ;; run the trans function.
          ;;  (format 0 "Trans | Proc ~A | C1: ~X C2: ~X C3: ~X C4: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*) (-> *canary-4*))
           (when (-> arg0 trans-hook)
             (let ((s4-0 (new 'process 'cpu-thread arg0 'trans 256 (-> arg0 main-thread stack-top))))
               (reset-and-call s4-0 (-> arg0 trans-hook))
               (delete s4-0)
               )
             (when (= (-> arg0 status) 'dead)
               (set! (-> s5-0 current-process) #f)
               (return 'dead)
               )
             )
           ;; run the main thread!
          ;;  (format 0 "Code | Proc ~A | C1: ~X C2: ~X C3: ~X C4: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*) (-> *canary-4*))
           (if (logtest? (-> arg0 mask) (process-mask sleep-code))
               (set! (-> arg0 status) 'suspended)
               ((-> arg0 main-thread resume-hook) (-> arg0 main-thread))
               )
          ;;  (format 0 "Finished Code | Proc ~A | C1: ~X C2: ~X C3: ~X C4: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*) (-> *canary-4*))
           (cond
             ((= (-> arg0 status) 'dead)
              (set! (-> s5-0 current-process) #f)
              'dead
              )
             (else
               ;; run post.
               ;; NOTE: post always runs on the dram stack, so you can use ja-post and use the scratchpad for anims.
               (when (-> arg0 post-hook)
                ;;  (format 0 "Post | Proc ~A | C1: ~X C2: ~X C3: ~X C4: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*) (-> *canary-4*))
                 (let ((s4-1 (new 'process 'cpu-thread arg0 'post 256 *kernel-dram-stack*)))
                   (reset-and-call s4-1 (-> arg0 post-hook))
                   (delete s4-1)
                   )
                ;;  (format 0 "Finished Post | Proc ~A | C1: ~X C2: ~X C3: ~X C4: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*) (-> *canary-4*))
                 (when (= (-> arg0 status) 'dead)
                   (set! (-> s5-0 current-process) #f)
                   (return 'dead)
                   )
                 (set! (-> arg0 status) 'suspended)
                 )
               (set! (-> s5-0 current-process) #f)
               #f
               )
             )
           )
          (('dead)
           'dead
           )
          )
        )
      )
    *kernel-context*
    )
  )

(defun sync-dispatcher ()
  "Run the REPL function."
  (let ((t9-0 *listener-function*))
    (when t9-0
      (set! *listener-function* #f)
      (t9-0)
      #f
      )
    )
  )

(defun inspect-process-tree ((tree process-tree) (depth int) (mask int) (detail symbol))
  "Display a tree-view of a process-tree."
  (print-tree-bitmask mask depth)
  (cond
    (detail
      (format #t "__________________~%")
      (format
        #t
        "~S~A~%"
        (if (zero? depth)
            ""
            "+---"
            )
        tree
        )
      (let ((s2-0 *print-column*))
        (set! *print-column* (the-as binteger (* (* depth 4) 8)))
        (inspect tree)
        (set! *print-column* s2-0)
        )
      )
    (else
      (format
        #t
        "~S~A~%"
        (if (zero? depth)
            ""
            "+---"
            )
        tree
        )
      )
    )
  (let ((s2-1 (-> tree child)))
    (while s2-1
      (inspect-process-tree
        (-> s2-1 0)
        (+ depth 1)
        (if (not (-> s2-1 0 brother))
            mask
            (logior mask (ash 1 (+ depth 1)))
            )
        detail
        )
      (set! s2-1 (-> s2-1 0 brother))
      )
    )
  tree
  )

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 ((this (the catch-frame (&+ (the pointer allocation) *gtype-basic-offset*))))
      ;; setup catch frame
      (set! (-> this type) type-to-make)
      (set! (-> this 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! (-> this ra) (the int temp))

      ;; todo, do we need a stack offset here?
      ;; remember the stack pointer
      (set! temp sp)
      (.sub temp off)
      (set! (-> this sp) (the int temp))

      ;; back up registers we care about
      (.mov :color #f temp s0)
      (set-u128-as-u64! (-> this rreg 0) temp)
      (.mov :color #f temp s1)
      (set-u128-as-u64! (-> this rreg 1) temp)
      (.mov :color #f temp s2)
      (set-u128-as-u64! (-> this rreg 2) temp)
      (.mov :color #f temp s3)
      (set-u128-as-u64! (-> this rreg 3) temp)
      (.mov :color #f temp s4)
      (set-u128-as-u64! (-> this rreg 4) temp)

      (.mov :color #f temp xmm8)
      (set! (-> this freg 0) (the-as float temp))
      (.mov :color #f temp xmm9)
      (set! (-> this freg 1) (the-as float temp))
      (.mov :color #f temp xmm10)
      (set! (-> this freg 2) (the-as float temp))
      (.mov :color #f temp xmm11)
      (set! (-> this freg 3) (the-as float temp))
      (.mov :color #f temp xmm12)
      (set! (-> this freg 4) (the-as float temp))
      (.mov :color #f temp xmm13)
      (set! (-> this freg 5) (the-as float temp))
      (.mov :color #f temp xmm14)
      (set! (-> this freg 6) (the-as float temp))
      (.mov :color #f temp xmm15)
      (set! (-> this freg 7) (the-as float temp))

      ;; push this stack frame
      (set! (-> this next) (-> pp stack-frame-top))
      (set! (-> pp stack-frame-top) this)

      ;; 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 ((this 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) (-> this next))

    ;; restore regs we care about.
    (set-u64-from-u128! temp (-> this rreg 0))
    (.mov :color #f s0 temp)
    (set-u64-from-u128! temp (-> this rreg 1))
    (.mov :color #f s1 temp)
    (set-u64-from-u128! temp (-> this rreg 2))
    (.mov :color #f s2 temp)
    (set-u64-from-u128! temp (-> this rreg 3))
    (.mov :color #f s3 temp)
    (set-u64-from-u128! temp (-> this rreg 4))
    (.mov :color #f s4 temp)

    (set! temp-float (-> this freg 0))
    (.mov :color #f xmm8 temp-float)
    (set! temp-float (-> this freg 1))
    (.mov :color #f xmm9 temp-float)
    (set! temp-float (-> this freg 2))
    (.mov :color #f xmm10 temp-float)
    (set! temp-float (-> this freg 3))
    (.mov :color #f xmm11 temp-float)
    (set! temp-float (-> this freg 4))
    (.mov :color #f xmm12 temp-float)
    (set! temp-float (-> this freg 5))
    (.mov :color #f xmm13 temp-float)
    (set! temp-float (-> this freg 6))
    (.mov :color #f xmm14 temp-float)
    (set! temp-float (-> this freg 7))
    (.mov :color #f xmm15 temp-float)

    ;; set stack pointer
    (set! sp (the uint (-> this sp)))
    (.add sp off)

    ;; overwrite our return address
    (.pop temp)
    (set! temp (the uint (-> this 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)
  )

(defmethod new protect-frame ((stack-addr symbol) (type-to-make type) (exit-func (function object)))
  "Allocate and set up a protect-frame. This _must_ be used on the stack."
  (with-pp
    (let ((v0-0 (the-as object (+ (the-as int stack-addr) 4))))
      (set! (-> (the-as protect-frame v0-0) type) type-to-make)
      (set! (-> (the-as protect-frame v0-0) name) 'protect-frame)
      (set! (-> (the-as protect-frame v0-0) exit) exit-func)
      (set! (-> (the-as protect-frame v0-0) next) (-> pp stack-frame-top))
      (set! (-> pp stack-frame-top) (the-as protect-frame v0-0))
      (the-as protect-frame v0-0)
      )
    )
  )

(defun previous-brother ((tree process-tree))
  "Get the process before this one, at this level."
  (let ((v1-0 (-> tree parent)))
    (when v1-0
      (let ((v1-2 (-> v1-0 0 child)))
        (if (= v1-2 tree)
            (return (the-as object #f))
            )
        (while v1-2
          (if (= (-> v1-2 0 brother) tree)
              (return (the-as object v1-2))
              )
          (set! v1-2 (-> v1-2 0 brother))
          )
        )
      (the-as (pointer process-tree) #f)
      )
    )
  )

(defun change-parent ((proc-to-change process-tree) (new-parent process-tree))
  "Reparent a process."
  (let ((a2-0 (-> proc-to-change parent)))
    (when a2-0
      (let ((v1-2 (-> a2-0 0 child)))
        (cond
          ((= (ppointer->process v1-2) proc-to-change)
           (set! (-> a2-0 0 child) (-> proc-to-change brother))
           )
          (else
            (while (!= (ppointer->process (-> v1-2 0 brother)) proc-to-change)
              (nop!)
              (nop!)
              (nop!)
              (set! v1-2 (-> v1-2 0 brother))
              )
            (set! (-> v1-2 0 brother) (-> proc-to-change brother))
            )
          )
        )
      )
    )
  (set! (-> proc-to-change parent) (-> new-parent ppointer))
  (set! (-> proc-to-change brother) (-> new-parent child))
  (set! (-> new-parent child) (-> proc-to-change ppointer))
  proc-to-change
  )

(defun change-brother ((arg0 process-tree) (arg1 process-tree))
  "Unused, and wrong."
  (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 ((proc process-tree))
  "Move this process to the end of its brother list."
  (when (and (-> proc brother) (-> proc parent))
    (let* ((a1-0 (-> proc parent))
           (v1-4 (-> a1-0 0 child))
           )
      (cond
        ((= (-> v1-4 0) proc)
         (set! (-> a1-0 0 child) (-> proc brother))
         )
        (else
          (while (!= (-> v1-4 0 brother 0) proc)
            (nop!)
            (nop!)
            (nop!)
            (nop!)
            (set! v1-4 (-> v1-4 0 brother))
            )
          (set! (-> v1-4 0 brother) (-> proc brother))
          )
        )
      (while (-> v1-4 0 brother)
        (nop!)
        (nop!)
        (nop!)
        (nop!)
        (set! v1-4 (-> v1-4 0 brother))
        )
      (set! (-> v1-4 0 brother) (-> proc ppointer))
      )
    (set! (-> proc brother) (the-as (pointer process-tree) #f))
    )
  proc
  )

(defmethod activate ((this process) (active-tree process-tree) (name string) (stack-pointer pointer))
  "Move a process from dead to active, moving it to the given tree."

  ;; if we got the scratchpad stack, move to the fake scratchpad.
  (#when PC_PORT
    (when (= stack-pointer *scratch-memory-top*)
      (set! stack-pointer (scratchpad-end))
      )
    )
  (set! (-> this mask)
        (logclear (-> active-tree mask) (process-mask sleep sleep-code process-tree heap-shrunk))
        )
  (+! (-> this clock ref-count) -1)
  (+! (-> active-tree clock ref-count) 1)
  (set! (-> this clock) (-> active-tree clock))
  (set! (-> this status) 'ready)
  (let ((v1-11 (-> *kernel-context* next-pid)))
    (set! (-> this pid) v1-11)
    (set! (-> *kernel-context* next-pid) (+ v1-11 1))
    )
  (set! (-> this top-thread) #f)
  (set! (-> this main-thread) #f)
  (set! (-> this name) name)
  (let ((v1-16 (&-> this stack (-> this type heap-base))))
    (set! (-> this heap-cur) v1-16)
    (set! (-> this heap-base) v1-16)
    )
  (set! (-> this stack-frame-top) #f)
  (mem-set32! (-> this stack) (the-as int (shr (-> this type heap-base) 2)) 0)
  (set! (-> this trans-hook) #f)
  (set! (-> this post-hook) #f)
  (set! (-> this event-hook) #f)
  (set! (-> this state) #f)
  (set! (-> this next-state) #f)
  (set! (-> this prev-state) #f)
  (set! (-> this state-stack) #f)
  (cond
    ((logtest? (-> active-tree mask) (process-mask process-tree))
     (set! (-> this entity) #f)
     (set! (-> this level) *default-level*)
     )
    (else
      (set! (-> this entity) (-> (the-as process active-tree) entity))
      (set! (-> this level) (-> (the-as process active-tree) level))
      )
    )
  (set! (-> this connection-list next1) #f)
  (set! (-> this connection-list prev1) #f)
  (set! (-> this main-thread) (new 'process 'cpu-thread this 'code 256 stack-pointer))
  (change-parent this active-tree)
  )

(defun run-function-in-process ((this 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 this)
                        ;; 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)
             )
           )
          (('dead)
           ;; died in init, this is fine.
           )
          (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)
    )
  )

;; definition for function set-to-run
(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))
    )
  )

;; definition for method 10 of type process-tree
;; WARN: Return type mismatch int vs none.
(defmethod deactivate ((this process-tree))
  "Make a process dead, clean it up, remove it from the active pool, and return to dead pool."
  0
  (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
                                  ;; og:preserve-this added parent
                                  :parent #f
                                  :exit #f
                                  :code #f
                                  :trans #f
                                  :post #f
                                  :enter #f
                                  :event #f)))
(set! (-> dead-state code) (the (function object :behavior process) nothing))

(define entity-deactivate-handler (the-as (function process entity-actor none) nothing))

(defmethod deactivate ((this process))
  "Make a process dead, clean it up, remove it from the active pool, and return to dead pool."
  (with-pp
    (when (!= (-> this status) 'dead)
      (set! (-> this next-state) dead-state)
      (if (-> this entity)
          (entity-deactivate-handler this (-> this entity))
          )
      (let ((s5-0 pp))
        (set! pp this)
        (let ((s4-0 (-> pp stack-frame-top)))
          (while (the-as protect-frame s4-0)
            (case (-> s4-0 type)
              ((protect-frame state)
               ((-> (the-as protect-frame s4-0) exit))
               )
              )
            (set! s4-0 (-> (the-as protect-frame s4-0) next))
            )
          )
        (set! pp s5-0)
        )
      (if (nonzero? process-disconnect) ;; added zero check.
          (process-disconnect this)
          )
      (let ((v1-12 (-> this child)))
        (while v1-12
          (let ((s5-1 (-> v1-12 0 brother)))
            (deactivate (-> v1-12 0))
            (set! v1-12 s5-1)
            )
          )
        )
      (return-process (-> this pool) this)
      (+! (-> this clock ref-count) -1)
      (set! (-> this state) #f)
      (set! (-> this next-state) #f)
      (set! (-> this prev-state) #f)
      (set! (-> this state-stack) #f)
      (set! (-> this entity) #f)
      (set! (-> this pid) 0)
      (cond
        ((= (-> *kernel-context* current-process) this)
         (set! (-> this status) 'dead)
         (abandon-thread)
         )
        ((= (-> this status) 'initialize)
         (set! (-> this status) 'dead)
         (throw 'initialize #f)
         )
        )
      (set! (-> this status) 'dead)
      )
    0
    (none)
    )
  )

;; failed to figure out what this is:
(kmemopen global "process-buffers")

(define *kernel-clock* (new 'static 'clock))
(define *vis-boot* #f)
(define *null-process* (new 'global 'process "null" 16))

(let ((v0-45 (new 'global 'process "listener" 2048)))
  (set! *listener-process* v0-45)
  (let ((gp-0 v0-45))
    (set! (-> gp-0 status) 'ready)
    (set! (-> gp-0 pid) 1)
    (set! (-> gp-0 main-thread) (new 'process 'cpu-thread gp-0 'main 256 *kernel-dram-stack*))
    )
  )

(define *16k-dead-pool* (new
                          'global
                          'dead-pool
                          (if *debug-segment*
                              1
                              0
                              )
                          #x4000
                          "*16k-dead-pool*"
                          )
        )

(define *8k-dead-pool* (new 'global 'dead-pool 4 #x2800 "*8k-dead-pool*"))
(define *4k-dead-pool* (new 'global 'dead-pool 4 4096 "*4k-dead-pool*"))
(define *target-dead-pool* (new 'global 'dead-pool 1 #x16800 "*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*"))
(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))
(define *default-dead-pool* (the-as dead-pool *nk-dead-pool*))
(define *pickup-dead-pool* (the-as dead-pool *nk-dead-pool*))
(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*
                            )
        )


(define *active-pool* (new 'global 'process-tree "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)
  )

(format 0 "Jak 3 kernel loaded!~%")