jak-project/goal_src/kernel/gkernel.gc

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

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

;; Fwd
(define-extern change-parent (function process-tree process-tree process-tree))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; System Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; HACK ADDED
(define *use-old-listener-print* #t)

;; Set version number symbols
(define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*)))
(define *irx-version* (the binteger (logior (ash *irx-major-version* 16) *irx-minor-version*)))

;; Set default options. The C Kernel may modify these before loading the engine.

;; Can be 'boot, 'listener, or 'debug-boot
;; set to 'boot when DiskBooting.
(define *kernel-boot-mode* 'listener) 

;; DebugBootLevel in C Kernel
(define *kernel-boot-level* (the symbol #f))

;; The number of DECI messages received.
;; The C Kernel increments this.
(define *deci-count* 0)

;; Some debug stats. Unused?
(define *last-loado-length* 0)
(define *last-loado-global-usage* 0)
(define *last-loado-debug-usage* 0)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relocate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Objects on a dynamic process heap may be relocated.
;; They should provide their own relocate method to do any fixups
;; for any references.
(defmethod relocate object ((this object) (offset int))
  this
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Package System
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The kernel has a weird package system. It's not really used and doesn't do much.
;; Both the C Kernel and GOAL Kernel update the kernel-packages list.
;; The list is used to avoid loading the same package multiple times.

(define *kernel-packages* '())

(defun load-package ((package string) (allocation kheap))
  "Load a Package from a CGO/DGO"
  (unless (nmember package *kernel-packages*)
    ;; #xf = OUTPUT_LOAD, OUTPUT_TRUE, EXECUTE, PRINT_LOGIN
    (dgo-load package allocation #xf #x200000)
    (set! *kernel-packages* (cons package *kernel-packages*))
    )
  )

(defun unload-package ((package string))
  "Mark a package as unloaded, if it was loaded previously"
  (let ((pack (nmember package *kernel-packages*)))
    (when pack
      (set! *kernel-packages* (delete! (car pack) *kernel-packages*))
      )
    *kernel-packages*
    )
  )


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

;; The kernel context is a global which stores the state of the kernel.
(define *kernel-context* (new 'static 'kernel-context
                              :prevent-from-run (process-mask execute sleep)
                              :next-pid 2
                              :current-process #f
                              :relocating-process #f
                              :low-memory-message #t
                              )
        )

;; the main stack for running GOAL code!
(define *dram-stack* (new 'global 'array 'uint8 DPROCESS_STACK_SIZE))
(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE))

;; I don't think this stack is used, but I'm not sure.
(set! (-> *kernel-context* fast-stack-top) *scratch-memory-top*)

;; A context with all process masks set to 0. This can be used to iterate through a process tree
;; without executing anything, to find a process for instance.
(define *null-kernel-context* (new 'static 'kernel-context))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Thread and CPU Thread
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; A GOAL thread represents the execution of code in a process.
; Each process has a "main thread", which is suspended and resumed.
; A process may also execute various temporary threads which always run until completion.
; A "temporary thread" cannot suspend and resume, but a "main thread" can.
; The currently executing thread of a process is the "top-thread".

; Some GOAL threads also have the ability to "back up" their stack, while others are "temporary".
; The main thread of a process can "back up" it's stack, and all others are temporary.

; All threads are actually cpu-threads. It's not clear why there are two separate types.
; Perhaps the thread was the public interface and cpu-thread is internal to the kernel?

(defmethod delete thread ((obj thread))
  "Clean up a thread. This assumes it's the top-thread of the process and restores the previous top thread."
  (when (eq? obj (-> obj process main-thread))
    ;; We have attempted to delete the main thread, which is bad.
    (break)
    )
  
  ;; restore the old top-thread.
  (set! (-> obj process top-thread) (-> obj previous))
  (none)
  )

(defmethod print thread ((obj thread))
  "Print 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 ((this thread) (stack-size int))
  "Set the backup stack size of a thread. This should only be done on the main-thread.
  This should be done immediately after allocating the main-thread"
  
  (let ((proc (-> this process)))
    (cond
      ((neq? this (-> proc main-thread))
       ;; oops. can only change the size of a main-thread's stack.
       (msg-err "illegal attempt change stack size of ~A when the main-thread is not the top-thread.~%" proc)
       (break) ;; ADDED
       )
      
      ((= (-> this stack-size) stack-size)
       ;; we already have this size. Don't do anything.
       )
      
      ((eq? (-> proc heap-cur) (&+ this (-> this type size) (- *gtype-basic-offset*) (-> this stack-size)))
       ;; our heap cur point to right after us. So we can safely bump it forward to give us more space.
       (set! (-> proc heap-cur) (the pointer (&+ this (-> this type size) (- *gtype-basic-offset*) stack-size)))
       (set! (-> this stack-size) stack-size)
       )
      (else
        (msg-err "illegal attempt change stack size of ~A after more heap allocation has occured.~%" proc)
        )
      )
    )
  (none)
  )

(defmethod new cpu-thread ((allocation symbol) (type-to-make type) (parent-process process) (name symbol) (stack-size int) (stack-top pointer))
  "Create a new CPU thread. Will allocate the main thread if none exists, otherwise a temp thread.
  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)"
  
  ;; first, let's see if we're doing the main or temp thread
  (let* ((obj (cond
                ((-> parent-process top-thread)
                 ;; we're allocating a temporary thread, the main thread already exists.
                 ;; we can stash the cpu-thread structure at the bottom of the stack.
                 ;; we assume the smaller PROCESS_STACK_SIZE
                 (the cpu-thread (&+ stack-top
                                     (- PROCESS_STACK_SIZE)
                                     *gtype-basic-offset*
                                     ))
                 )
                (else
                  ;; the main thread. We need the main thread's cpu-thread to stick around, so we put it in the 
                  ;; process heap.
                  (let ((alloc (align16 (-> parent-process heap-cur)))) ;; start at heap cur, aligned
                    ;; bump heap to include our thread + its stack
                    (set! (-> parent-process heap-cur) (the pointer (+ alloc (-> type-to-make size) stack-size)))
                    (the cpu-thread (+ alloc *gtype-basic-offset*))
                    )
                  )
                )))
    
    ;; set up the type manually, as we allocated the memory manually
    (set! (-> obj type) type-to-make)
    
    ;; set up thread
    (set! (-> obj name) name)
    (set! (-> obj process) parent-process)
    ;; start stack at the top
    (set! (-> obj sp) stack-top)
    (set! (-> obj stack-top) stack-top)
    ;; remember the previous thread, in case we're a temp thread
    (set! (-> obj previous) (-> parent-process top-thread))
    ;; and make us the top!
    (set! (-> parent-process top-thread) obj)
    
    ;; set up our suspend/resume hooks. By default just use the thread's methods.
    ;; but something else could install a different hook if needed.
    (set! (-> obj suspend-hook) (method obj thread-suspend))
    (set! (-> obj resume-hook) (method obj thread-resume))
    
    ;; remember how much space we have for the backup stack.
    (set! (-> obj stack-size) stack-size)
    obj
    )
  )


(defmethod asize-of cpu-thread ((obj cpu-thread))
  "Get the size of a cpu-thread"
  ;; we need this because the cpu-thread is stored in the process stack
  (the int (+ (-> obj type size) (-> obj stack-size)))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Remove Exit
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun remove-exit ()
  "This is likely a defbehavior for process.
  Pops a single stack frame, if there is one."
  (rlet ((self :reg r13 :type process))
        (when (-> self stack-frame-top)
          (set! (-> self stack-frame-top) (-> self stack-frame-top next))
          )
        )
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Tree
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; GOAL processes are stored in a left child, right sibling tree.
;; The base class of process is process-tree.
;; Each process-tree element has a process-mask which indicates what type of node it is.

(defun-debug stream<-process-mask (stream (mask int))
  "Print out a process mask. This function may have been auto-generated?"
  ; 24
  (if (not (eq? 0 (logand mask (process-mask death))))
      (format stream "death "))
  ; 23
  (if (not (eq? 0 (logand mask (process-mask attackable))))
      (format stream "attackable "))  
  ; 22
  (if (not (eq? 0 (logand mask (process-mask projectile))))
      (format stream "projectile "))  
  ; 21
  (if (not (eq? 0 (logand mask (process-mask entity))))
      (format stream "entity "))
  ; 20
  (if (not (eq? 0 (logand mask (process-mask ambient))))
      (format stream "ambient "))    
  ; 19
  (if (not (eq? 0 (logand mask (process-mask platform))))
      (format stream "platform "))
  ; 18
  (if (not (eq? 0 (logand mask (process-mask camera))))
      (format stream "camera "))  
  ; 17
  (if (not (eq? 0 (logand mask (process-mask enemy))))
      (format stream "enemy "))  
  ; 16
  (if (not (eq? 0 (logand mask (process-mask collectable))))
      (format stream "collectable "))
  ; 15
  (if (not (eq? 0 (logand mask (process-mask crate))))
      (format stream "crate "))  
  ; 14
  (if (not (eq? 0 (logand mask (process-mask sidekick))))
      (format stream "sidekick "))
  ; 13
  (if (not (eq? 0 (logand mask (process-mask target))))
      (format stream "target "))  
  ; 12
  (if (not (eq? 0 (logand mask (process-mask movie-subject))))
      (format stream "movie-subject "))
  ; 11
  (if (not (eq? 0 (logand mask (process-mask movie))))
      (format stream "movie "))
  ; 10
  (if (not (eq? 0 (logand mask (process-mask going))))
      (format stream "going "))  
  ; 9
  (if (not (eq? 0 (logand mask (process-mask heap-shrunk))))
      (format stream "heap-shrunk "))
  ; 8
  (if (not (eq? 0 (logand mask (process-mask process-tree))))
      (format stream "process-tree "))  
  ; 7
  (if (not (eq? 0 (logand mask (process-mask sleep-code))))
      (format stream "sleep-code "))
  ; 6
  (if (not (eq? 0 (logand mask (process-mask sleep))))
      (format stream "sleep "))  
  ; 5
  (if (not (eq? 0 (logand mask (process-mask actor-pause))))
      (format stream "actor-pause "))  
  ; 4
  (if (not (eq? 0 (logand mask (process-mask progress))))
      (format stream "progress "))
  ; 3
  (if (not (eq? 0 (logand mask (process-mask menu))))
      (format stream "menu "))    
  ; 2
  (if (not (eq? 0 (logand mask (process-mask pause))))
      (format stream "pause "))
  ; 1
  (if (not (eq? 0 (logand mask (process-mask draw))))
      (format stream "draw "))  
  ; 0
  (if (not (eq? 0 (logand mask (process-mask execute))))
      (format stream "execute "))  
  )

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

(defmethod new process-tree ((allocation symbol) (type-to-make type) (name basic))
  "Create a process-tree node"
  ;; allocate
  (let ((obj (object-new)))
    (set! (-> obj name) name)
    (set! (-> obj mask) (process-mask process-tree))
    (set! (-> obj parent) #f)
    (set! (-> obj brother) #f)
    (set! (-> obj child) #f)
    
    (set! (-> obj self) obj)
    (set! (-> obj ppointer) (&-> obj self))
    obj
    )
  )

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


(defmethod new process ((allocation symbol) (type-to-make type) (name basic) (stack-size int))
  "Allocate a new process.
  The process stack is initially set to the entire process memory."
  (let ((obj (if (eq? (-> allocation type) symbol)
                 (object-new (the int (+ (-> process size) stack-size))) ;; symbol, allocate on heap
                 (the process (&+ allocation *gtype-basic-offset*)))))   ;; treat as address.
    
    ;; initialize
    (set! (-> obj name) name)
    (set! (-> obj status) 'dead)
    (set! (-> obj pid) 0)
    (set! (-> obj pool) #f)
    (set! (-> obj allocated-length) stack-size)
    (set! (-> obj top-thread) #f)
    (set! (-> obj main-thread) #f)
    
    ;; set up the heap to start at the stack
    (set! (-> obj heap-cur) (-> obj stack))
    (set! (-> obj heap-base) (-> obj stack))
    
    ;; and end at the end of the stack.
    (set! (-> obj heap-top) (&-> (-> obj stack) (-> obj allocated-length)))
    ;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; heap top-base bug
    ;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; original there was something like (set! (-> heap-top-base) (-> heap-top))
    ;; but this overlaps with the stack-frame-top and did nothing.
    ;; this is likely because they added the concept of heap "top" to kheaps in
    ;; general, but not to process heaps.
    
    ;; setup state stuff
    (set! (-> obj stack-frame-top) #f)
    (set! (-> obj state) #f)
    (set! (-> obj next-state) #f)
    (set! (-> obj entity) #f)
    
    ;; setup handlers
    (set! (-> obj trans-hook) #f)
    (set! (-> obj post-hook) #f)
    (set! (-> obj event-hook) #f)

    ;; setup process tree
    (set! (-> obj parent) #f)
    (set! (-> obj brother) #f)
    (set! (-> obj child) #f)
    
    ;; setup reference stuff.
    (set! (-> obj self) obj)
    (set! (-> obj ppointer) (&-> obj self))
    obj
    )            
  )

(defun inspect-process-heap ((obj process))
  "Inspect the heap of a process."
  (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.
      (set! ptr (&+ ptr (align16 (asize-of (the basic ptr)))))
      )
    )
  )

(defmethod inspect process ((obj process))
  (format #t "[~8x] ~A~%" obj (-> obj type))
  (format #t "~Tname: ~S~%" (-> obj name))
  (format #t "~Tmask: #x~X~%" (-> obj mask))
  (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 "~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~%" (as-process (-> obj parent)))
  (format #t "~Tbrother: ~A~%" (as-process (-> obj brother)))
  (format #t "~Tchild: ~A~%" (as-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))

  ;; print all objects on the process heap
  (protect (*print-column*)
    (+! *print-column* *tab-size*)
    (format #t "----~%")
    (inspect-process-heap obj)
    (format #t "----~%")
    )

  (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))
  (the int (+ (-> process size) (-> obj allocated-length)))
  )

(defmethod print process ((obj process))
  (format #t "#<~A ~S ~A :state ~S " 
          (-> obj type) 
          (-> obj name) 
          (-> obj status) 
          (when (-> obj state) (-> obj state name)))
  
  (format #t ":stack ~D/~D :heap ~D/~D @ #x~X>"
          (process-stack-used obj)
          (process-stack-size obj)
          (process-heap-used obj)
          (process-heap-size obj)
          obj
          )
  obj
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Context Suspend And Resume - Kernel
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; the following functions are used for going from the kernel to temporary 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
  at the end of a normal function, so this should preserve rax."
  (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
        (.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)
        )
  )

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

(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."
  (declare (asm-func object)
           ;(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)
         (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) 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
        ;(.push 0) ;; for 16-byte stack alignment.
        (set! temp (the uint return-from-thread))
        (.add temp off)
        (.push temp)
        ;; and call the function!
        (.add func off)
        (.jr func)
        )
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Context Suspend And Resume - Thread
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; these are for resuming and suspending a thread.

(defmethod thread-suspend cpu-thread ((unused cpu-thread))
  "Suspend the thread and return to the kernel."
  
  (declare (asm-func none)
           ;(print-asm)
           )
  
  ;; 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))
        
        ;; get the return address pushed by "call"
        (.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)
        
        ;; todo, back up fprs
        
        ;; get our process
        (let ((proc (-> obj process)))
          (when (> (process-stack-used proc) (-> obj stack-size))
            (break) ;; too much stack has been used and we can't suspend!
            )
          
          ;; mark the process as suspended and copy the stack
          (set! (-> proc status) 'suspended)
          (let ((cur (the (pointer uint64) (-> obj stack-top)))
                (save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
                )
            (while (> (the int cur) (the int sp))
              (set! cur (the (pointer uint64) (&- cur 8)))
              (set! save (the (pointer uint64) (&- save 8)))
              (set! (-> save) (-> cur))
              )
            )
          )
        
        ;; actually setting pp to 0
        (set! obj (the cpu-thread 0))
        
        ;; get the kernel stack pointer as a GOAL pointer
        (.load-sym :sext #f sp *kernel-sp*)
        ;; convert it back to a real pointer
        (.add sp off)
        
        ;; restore saved registers...
        ;; without coloring system because this is "cheating".
        (.pop :color #f s4)
        (.pop :color #f s3)
        (.pop :color #f s2)
        (.pop :color #f s1)
        (.pop :color #f s0)
        ;; return to the kernel function that called the user code
        (.ret)
        )
  (none)
  )


(defmethod thread-resume cpu-thread ((thread-to-resume cpu-thread))
  (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)) 
        
        ;; 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.
        (set! sp (the uint (-> obj sp)))
        
        ;; restore the stack.
        (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 looking at it.
        (.add sp off)
        
        ;; setup process
        (set! (-> (-> obj process) top-thread) obj)
        (set! (-> (-> obj process) status) 'running)
        
        ;; restore reg
        (set! temp (-> obj rreg 0))
        (.mov :color #f s0 temp)
        (set! temp (-> obj rreg 1))
        (.mov :color #f s1 temp)
        (set! temp (-> obj rreg 2))
        (.mov :color #f s2 temp)
        (set! temp (-> obj rreg 3))
        (.mov :color #f s3 temp)
        (set! temp (-> obj rreg 4))
        (.mov :color #f s4 temp)
        
        ;; todo restore fpr.
        
        (set! temp (the uint (-> obj pc)))
        (.add temp off)
        (set! obj (the cpu-thread (-> obj process)))
        (.jr temp)
        )
  (none)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Dead Pool
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; a dead-pool is a collection of processes of fixed size that you can get processes from.

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

(defmethod new dead-pool ((allocation symbol) (type-to-make type) (count int) (stack-size int) (name basic))
  "Create a pool of count dead processes, each with a fixed size stack-size"
  (let ((obj (object-new)))
    ;; setup process naming
    (set! (-> obj name) name)
    (set! (-> obj mask) (process-mask process-tree))
    ;; setup process tree
    (set! (-> obj parent) #f)
    (set! (-> obj brother) #f)
    (set! (-> obj child) #f)
    ;; setup ref
    (set! (-> obj self) obj)
    (set! (-> obj ppointer) (&-> obj self))
    
    (dotimes (i count)
      ;; create each process
      (let ((old-bro (-> obj child))
            (next ((method process new) allocation process 'dead stack-size)))
        (set! (-> obj child) (as-ppointer next))
        (set! (-> next parent) (as-ppointer obj))
        (set! (-> next pool) obj)
        (set! (-> next brother) old-bro)
        )
      )
    obj
    )
  )

(defmethod get-process dead-pool ((obj dead-pool) (type-to-make type) (stack-size int))
  "Get a process from this dead pool of the given type." 
  (let ((proc (-> obj child)))
    
    (when (and (not proc) *debug-segment* (neq? obj *debug-dead-pool*))
      ;; we failed, but we're in debug mode and not looking at the debug pool
      ;; try again from the debug pool and warn if this works
      (set! proc (the (pointer process-tree) (get-process *debug-dead-pool* type-to-make stack-size)))
      (when proc
        (format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
                type-to-make (as-process proc) (-> obj name))
        )
      ;; there's a bug here. proc is a process here, but will be used as a process pointer.
      ;; let's just kill the program here.
      ;; this is likely a copy-paste bug from get-process dead-pool-heap.
      (break) 
      )
    
    (cond
      (proc
        ;; success! set our type and return.
        (set! (-> (-> proc) type) type-to-make)
        (the process (-> proc)) ;; cast from process-tree to process.
        )
      (else
        (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
                type-to-make (as-process proc) (-> obj name))
        (the process #f)
        )
      )
    )
  )


(defmethod return-process dead-pool ((obj dead-pool) (proc process))
  "Return a process to its pool once you are done with it."
  (change-parent proc obj)
  (none)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Dead Pool Heap
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
; these processes start out with a lot of memory, then shrink their heap (compact) to the size
; they actually need.  To avoid heap fragmentation, the dead-pool-heap system will relocate
; processes. This requires that you implement the relocate method on your process.

(define-extern *null-process* process)

(defmethod new dead-pool-heap ((allocation symbol) (type-to-make type) (name basic) (allocated-length int) (heap-size int))
  "Create a new dead pool heap. It will support allocated-length processes and have a total heap size of heap-size"
  (let ((obj (object-new (+ (the int (-> type-to-make size))
                            (align16 (* allocated-length 12))
                            heap-size))))
    (set! (-> obj name) name)
    (set! (-> obj mask) (process-mask process-tree))
    (set! (-> obj allocated-length) allocated-length)
    (set! (-> obj parent) #f)
    (set! (-> obj brother) #f)
    (set! (-> obj child) #f)
    
    (set! (-> obj self) obj)
    (set! (-> obj ppointer) (&-> obj self))
    
    ;; initialize each process handle
    ;; build them into a linked list of null-process
    (countdown (i allocated-length)
      (let ((rec (-> obj process-list i)))
        (set! (-> rec process) *null-process*)
        (set! (-> rec next) (-> obj process-list (+ i 1)))
        )
      )
    
    ;; set up the dead-list
    (set! (-> obj dead-list next) (-> obj process-list 0))
    (set! (-> obj alive-list process) #f) ;; likely typo here, should be dead-list
    (set! (-> obj process-list (- allocated-length 1) next) #f)
    
    ;; nothing is alive 
    (set! (-> obj last) (-> 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)
    
    ;; setup the heap. It just begins after the process records.
    (set! (-> obj heap base) (the pointer (align16 (-> obj process-list allocated-length))))
    (set! (-> obj heap current) (-> obj heap base))
    (set! (-> obj heap top) (&+ (-> obj heap base) heap-size))
    (set! (-> obj heap top-base) (-> obj heap top))
    obj
    )
  )

(defmethod gap-location dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec))
  "Get the gap after the given process. 
  If root of the alive list is given, will give the first gap between the heap and the first process.
  If there is no gap, may point to the next process. Not 16-byte aligned."
  (cond
    ((-> rec process)
     (the pointer (&+ (-> rec process) (-> process size) (-> rec process allocated-length) (- *gtype-basic-offset*)))
     ;;               start of proc     end of type data  process's heap                   basic offset
     )
    (else
      (-> obj heap base)
      )
    )
  )

(defmethod gap-size dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec))
  "Determine the size between the given process and the next process or end of the heap.
   If you give the first rec, it will given the gap between the beginning of the heap and the next process."
  (the int
       (cond
         ((-> rec process)
          ;; compute the end of my process (no basic offset)
          (let ((my-end (&+ (-> rec process) (-> process size) (-> rec process allocated-length))))
            (if (-> rec next)
                ;; if there's a next process, look at the difference to the next (basic offsets cancel)
                (&- (-> rec next process) my-end)
                ;; no next process, look at the top of the heap.
                (&- (-> obj heap top) (&+ my-end *gtype-basic-offset*))
                )
            )
          )
         (else
           (if (-> rec next)
               (&- (-> rec next process) (&+ (-> obj heap base) *gtype-basic-offset*))
               (&- (-> obj heap top) (-> obj heap base)))
           )
         )
       )
  )

(defmethod find-gap dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec))
  "Start at the given record and find the closest gap after it. Returns the rec
  which has the gap after it. If no gaps, returns the last rec."
  (while (and (-> rec next) (zero? (gap-size obj rec)))
    ; no gap here!
    (set! rec (-> rec next))
    )
  rec
  )


(defmethod inspect dead-pool-heap ((obj dead-pool-heap))
  "Inspect a dead-pool-heap and all of the recs and their gaps"
  (format #t "[~8x] ~A~%" obj (-> obj type))
  (format #t "~Tname: ~A~%" (-> obj name))
  (format #t "~Tmask: ~D~%" (-> obj mask))
  (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 last))
  (format #t "~Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj dead-list))
  
  ;; here we consider the free memory to be all of the stuff after the last process.
  ;; we don't consider random gaps to be "free".
  ;; this means you can do a single allocation of free bytes and it will always succeed.
  (let* ((total (the int (&- (-> obj heap top) (-> obj heap base))))
         (free (if (-> obj last)
                   (gap-size obj (-> obj last))
                   total))
         )
    (format #t "~Tprocess-list[0] @ #x~X     ~D/~D bytes used~%" (-> obj process-list) (- total free) total)
    )
  
  (let ((rec (-> obj alive-list))
        (i 0)
        )
    (while rec
      (when (-> rec process)
        (format #t "~T  [~3D] #<dead-pool-heap-rec @ #x~X>  ~A~%" i rec (-> rec process))
        )
      (let ((gap (gap-size obj rec)))
        (unless (zero? gap)
          (format #t "~T   gap: ~D bytes @ #x~X~%" gap (gap-location obj rec)))
        )
      (set! rec (-> rec next))
      (+! i 1)
      )
    )
  
  obj)

(defmethod asize-of dead-pool-heap ((obj dead-pool-heap))
  "Get our total size. Uses the heap top as the end."
  (- (the int (-> obj heap top)) (the int obj) *gtype-basic-offset*)
  )

(defmethod memory-used dead-pool-heap ((obj dead-pool-heap))
  "Get the amount of memory used. This includes gaps between processes."
  (if (-> obj last)
      ; we have at least one process, get the not-last-gap memory
      (- (memory-total obj) (gap-size obj (-> obj last)))
      ; no processes.
      0
      )
  )

(defmethod memory-total dead-pool-heap ((obj dead-pool-heap))
  "Get the total amount of memory for processes"
  (the int (&- (-> obj heap top) (-> obj heap base)))
  )

(defmethod memory-free dead-pool-heap ((obj dead-pool-heap))
  "Get the total memory free."
  (let ((top (-> obj heap top)))
    (if (-> obj last)
        ; get the last gap size
        (gap-size obj (-> obj last))
        ; otherwise just the whole heap.
        (the int (&- top (-> obj heap base)))
        )
    )
  )

(defmethod compact-time dead-pool-heap ((obj dead-pool-heap))
  "Access the compact time field."
  (-> obj compact-time)
  )

(defmethod find-gap-by-size dead-pool-heap ((obj dead-pool-heap) (size int))
  "Find a gap which will fit at least size bytes. Returns the rec for the proc before the gap.
  Will return a #f rec if there's no gap big enough."
  ; start our search at first-gap
  (let ((rec (-> obj first-gap)))
    (while (and rec (< (gap-size obj rec) size))
      ;; nope, not big enough.
      (set! rec (-> rec next))
      )
    rec
    )
  )

(define-extern *vis-boot* basic)

(defmethod get-process dead-pool-heap ((obj dead-pool-heap) (type-to-make type) (stack-size int))
  "Allocate a process"
  
  ;; get a record for the new process
  (let ((rec (-> obj dead-list next))
        ;; will eventually hold our new process
        (proc (the process #f))
        ;; find the rec which has a big enough gap
        (insert (find-gap-by-size obj (+ (the int (-> process size)) stack-size)))
        )
    
    (cond
      ;; check we got both a record and a gap
      ((and rec insert)
       
       ;; pop the record off of the list
       (set! (-> obj dead-list next) (-> rec next))
       
       ;; splice it into the alive list in the right spot
       (let ((next (-> insert next)))
         ;; after the gap rec
         (set! (-> insert next) rec)
         ;; us to the process after the gap
         (set! (-> rec next) next)
         
         ;; link the proc after us back
         (when next
           (set! (-> next prev) rec)
           )
         ;; and us back to the proc before the gap
         (set! (-> rec prev) insert)
         
         ;; if we are inserting after the last process, we should update the last.
         (when (eq? insert (-> obj last))
           (set! (-> obj last) rec)
           )
         
         ;; get the gap
         (set! proc (the process (gap-location obj insert)))
         ;; and allocate! The method new does the offset for us.
         (set! proc ((method process new) (the symbol proc) process 'process stack-size))
         
         ;; update our rec to contain this process.
         (set! (-> rec process) proc)
         ;; and the ppointer should point to the rec, not the processs, so we can track the process if it moves.
         (set! (-> proc ppointer) (&-> rec process))
         
         ;; if we used the first gap, update first gap
         (when (eq? (-> obj first-gap) insert)
           (set! (-> obj first-gap) (find-gap obj rec))
           )
         
         ;; we haven't shrunk yet. If we don't have a first-shrink, or we are before it,
         ;; mark us as first shrink.
         (when (or (not (-> obj first-shrink))
                   (< (the int proc) (the int (-> obj first-shrink process)))
                   )
           (set! (-> obj first-shrink) rec)
           )
         
         ;; update tree stuff.
         (set! (-> proc parent) (-> obj ppointer))
         (set! (-> proc pool) obj)
         (set! (-> obj child) (&-> rec process))
         )
       
       )
      (else
        ;; allocation failed! try again on the debug heap if we're debugging.
        (when (and *debug-segment* (not (eq? obj *debug-dead-pool*)))
          (set! proc (get-process *debug-dead-pool* type-to-make stack-size))
          (when (and proc *vis-boot*)
            (format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%" type-to-make proc (-> obj name)))
          )
        
        )
      )
    
    (cond
      (proc
        ;; success! set type and return.
        (set! (-> proc type) type-to-make)
        )
      (else
        ;; failure. complain.
        (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" type-to-make proc (-> obj name))
        )
      )
    
    proc)
  )

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

(define-extern *stdcon* basic) ;; todo, more specific

(defmethod compact dead-pool-heap ((obj dead-pool-heap) (count int))
  "Do heap compaction.  The count argument tells us how much work to do.
  If the heap is very full we will automatically do more work than requested."
  
  ;; first we see how much memory is in use.
  (let ((free (memory-free obj))
        (total (memory-total obj))
        )
    (let ((perc (/ (the float free) (the float total))))
      (cond
        ((< perc 0.1)
         ;; 90% full! set count very large to try to fix this and complain.
         (set! count 1000)
         (when (and *debug-segment* (-> *kernel-context* low-memory-message))
           (format *stdcon* "~3LLow Actor Memory~%~0L")
           )
         )
        ((< perc 0.2)
         ;; 80% full, try 4x harder
         (set! count (* count 4))
         )
        ((< perc 0.3)
         ;; 70% full, try 2x harder
         (set! count (* count 2))
         )
        )
      )
    )
  
  ;; update stats
  (set! (-> obj compact-count-targ) count)
  (set! (-> obj compact-count) 0)
  
  ;; and do compaction!
  (countdown (ii count)
    
    ;; first try to shrink a heap.
    (let ((shrink (-> obj first-shrink)))
      (when (not shrink)
        ;; not sure when this happens, but reset shrink if we need to.
        (set! shrink (set! (-> obj first-shrink) (-> obj alive-list next)))
        )
      (when shrink
        ;; do a shrink!
        (shrink-heap obj (-> shrink process))
        )
      )
    
    ;; now find the first gap
    (let ((gap (-> obj first-gap)))
      ;; and the thing after it
      (when (-> gap next)
        (let ((proc (-> gap next process))
              (size (gap-size obj gap)))
          (unless (zero? size)
            (format #t "[kernel] Relocating process ~A by ~D.~%" proc (- size))
            (when (< size 0)
              ;; bug!
              (break)
              )
            
            ;; try shrinking before relocating.
            (shrink-heap obj proc)
            ;; relocate!
            (relocate proc (- size))
            ;; update first gap
            (set! (-> obj first-gap) (find-gap obj gap))
            ;; and update stats.
            (+! (-> obj compact-count) 1)
            )
          )
        )
      )
    )
  
  (none)
  )

(defmethod churn dead-pool-heap ((obj dead-pool-heap) (count int))
  "Mess with the heap"
  
  (countdown (ii count)
    (let ((rec (-> obj alive-list next)))
      (when rec
        (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)))
        

        (when (eq? (-> obj first-shrink) rec)
          (set! (-> obj first-shrink) (-> rec prev))
          (when (not (-> obj first-shrink process))
            (set! (-> obj first-shrink) #f))
          )
        
        (set! (-> rec prev next) (-> rec next))
        (cond
          ((-> rec next)
           (set! (-> rec next prev) (-> rec prev))
           )
          (else
            (set! (-> obj last) (-> rec prev))
            )
          )
        
        (let* ((insert (-> obj last))
               (next (-> insert next))
               )
          
          (set! (-> insert next) rec)
          (set! (-> rec next) next)
          (when next
            (set! (-> next prev) rec))
          (set! (-> rec prev) insert)
          
          (set! (-> obj last) rec)
          (set! (-> rec process) (relocate (-> rec process) (the int (&- (gap-location obj insert) 
                                                                         (the int (&- (-> rec process) *gtype-basic-offset*))))))
          )
        )
      )
    )
  
  (none)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Finding
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; GOAL lambdas aren't real lambdas, so you have to do this.
(define *global-search-name* (the basic #f))
(define *global-search-count* 0)

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

(defun process-by-name (name (pool process-tree))
  "Look up a process in the given pool by name"
  (set! *global-search-name* (the basic name))
  (the process (search-process-tree pool (lambda ((var process))
                                           (name= (-> var name) *global-search-name*))))
  )

(defun process-not-name (name (pool process-tree))
  "Look up a process with not the given name."
  (set! *global-search-name* (the basic name))
  (the process (search-process-tree pool (lambda ((var process))
             (not (name= (-> var name) *global-search-name*)))))
  )

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

(defun kill-by-name (name (pool process-tree))
  "Call deactivate on all process with the given name."
  (let ((proc (the process-tree #f)))
    (while (set! proc (process-by-name name pool))
      (deactivate proc)
      )
    )
  )

(defun kill-by-type (type (pool process-tree))
  "Call deactivate on all processes with the given type"
  (break) ; this is sketchy.
  (set! *global-search-name* (the basic type))
  (let ((proc (the process-tree #f)))
    (while (set! proc (search-process-tree pool (lambda ((var process))
                                                  (= (the type *global-search-name*)
                                                     (-> var type)))))
      (deactivate proc)
      )
    )
  )

(defun kill-not-name (name (pool process-tree))
  "Call deactivate on all processes that don't match the name"
  (let ((proc (the process-tree #f)))
    (while (set! proc (process-not-name name pool))
      (deactivate proc)
      )
    )
  )

(defun kill-not-type (type (pool process-tree))
  "Call deactivate on all prcesses that don't match the given type"
  (break) ;; this function is weird.
  (set! *global-search-name* (the basic type))
  (let ((proc (the process-tree #f)))
    (while (set! proc (search-process-tree pool (lambda ((var process))
                                                  (!= (the type *global-search-name*)
                                                     (-> var type)))))
      (deactivate proc)
      )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Iterating
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod run-logic? process ((obj process))
  "Return if the process should be run or not."
  #t)

;; the following three functions recursively iterate through process trees.

(defun iterate-process-tree ((obj process-tree) (func (function object object)) (context kernel-context))
  "Call func on all processes that aren't a process-tree. If func returns 'dead, stop.
  The kernel-context is ignored."
  (let ((ret (or (process-mask? (-> obj mask) process-tree)
                 (func obj))))
    (cond
      ((eq? ret 'dead)
       ;; stop.
       )
      (else
        ;; iterate through brothers
        (let ((brother (-> obj child)))
          (while brother
            ;; kinda weird, we use the brother from _before_ recursing.
            (let ((old-brother (-> (-> brother) brother)))
              (iterate-process-tree (-> brother) func context)
              (set! brother old-brother)
              )
            )
          )
        )
      )
    ret
    )
  )

(defun execute-process-tree ((obj process-tree) (func (function object object)) (context kernel-context))
  "Like iterate, but also requires that prevent-from-run's mask doesn't block, and that run-logic?
  is true in order to call the function."
  
  ;; check mask for tree, mask for prevent, run-logic?, then run!
  (let ((ret (or (process-mask? (-> obj mask) process-tree)
                 (not (and (or (zero? (logand (-> context prevent-from-run) (-> obj mask))))
                           (run-logic? obj)))
                 (func obj)
                 )))
    
    ;; run on our children
    (cond
      ((eq? ret 'dead)
       )
      (else (let ((brother (-> obj child)))
              (while brother
                (let ((temp (-> (-> brother) brother)))
                  (execute-process-tree (-> brother) func context)
                  (set! brother temp))
                )
              )
            )
      )
    ret)
  )


(defun search-process-tree ((obj process-tree) (func (function process-tree object)))
  "Find the first process which func return true on. Won't find process-tree's (by mask)"
  
  ;; reject process-tree
  (unless (process-mask? (-> obj mask) process-tree)
    ;; is this a match?
    (when (func obj)
      (return-from #f (the process obj))
      )
    )
  
  ;; not a match, check out children
  (let ((brother (-> obj child)))
    (while brother
      (let ((temp (-> (-> brother) brother)))
        (let ((ret (search-process-tree (-> brother) func)))
          (when ret
            (return-from #f (the process ret))
            )
          )
        (set! brother temp)
        )
      )
    )
  (the process #f)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Dispatcher
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-extern *listener-process* process)
(define-extern *active-pool* process-tree)
(define-extern *stdcon0* basic) ; more specific?
(define-extern *stdcon1* basic) ; more specific?
(define-extern *debug-draw-pauseable* symbol)

(defun kernel-dispatcher ()
  "Run the kernel!
  "
  
  (when *listener-function*
    (let ((result (reset-and-call (-> *listener-process* main-thread) *listener-function*)))
      (if *use-old-listener-print*
          (format #t "~D~%" result result result)
          (format #t "~D        #x~X        ~F        ~A~%" result result result result)
          )
      )
    (set! *listener-function* #f)
    (+! *enable-method-set* -1)
    )
  
  
  (execute-process-tree 
    *active-pool* 
    (lambda ((obj process))
      (format 0 "Call to dispatcher lambda!~%")
      (let ((context *kernel-context*))
        
        (cond
          ((or (eq? (-> obj status) 'waiting-to-run)
               (eq? (-> obj status) 'suspended))
           
           ;; we should run!
           ;; set current process to us
           (set! (-> context current-process) obj)
           
           ;; update pause junk for this run
           (cond
             ((process-mask? (-> obj mask) pause)
              ;; we're paused.
              (set! *stdcon* *stdcon1*)
              (set! *debug-draw-pauseable* #t)
              )
             (else
               (set! *stdcon* *stdcon0*)
               (set! *debug-draw-pauseable* #f)
               )
             )
           
           ;; TRANS
           (cond
             ((-> obj trans-hook)
              ;; we have a trans hook defined. let's create a thread and run it. we can reuse the stack of the main-thread
              ;; it is safe to do this because the main-thread is currently suspended or hasn't run yet.
              ;; hack process -> global new todo 
              (let ((trans (new 'global 'cpu-thread obj 'trans PROCESS_STACK_SAVE_SIZE (-> obj main-thread stack-top))))
                ;; call the function in the thread.
                (reset-and-call trans (-> obj trans-hook))
                ;; remove the cpu-thread
                (delete trans)
                ;; check for deadness
                (when (eq? (-> obj status) 'dead)
                  (set! (-> context current-process) #f)
                  (return-from #f 'dead)
                  )
                )
              )
             )
           
           ;; MAIN CODE
           (if (process-mask? (-> obj mask) sleep-code)
               ;; we're sleeping. Move us to suspended, in case we were in waiting to run.
               (set! (-> obj status) 'suspended)
               ;; not sleeping. call resume hook
               ((-> obj main-thread resume-hook) (-> obj main-thread))
               )
           ;; check for deadness
           (cond
             ((eq? (-> obj status) 'dead)
              ;; oops we died. return 'dead
              (set! (-> context current-process) #f)
              'dead
              )
             (else
               ;; not dead.
               ;; POST CODE
               (cond
                 ((-> obj post-hook)
                  ;; hack process -> global new todo 
                  (let ((post (new 'global 'cpu-thread obj 'post PROCESS_STACK_SAVE_SIZE *kernel-dram-stack*)))
                    (reset-and-call post (-> obj post-hook))
                    (delete post)
                    (when (eq? (-> obj status) 'dead)
                      ;; oops we died.
                      (set! (-> context current-process) #f)
                      (return-from #f 'dead)
                      )
                    (set! (-> obj status) 'suspended)
                    )
                  )
                 )
               (set! (-> context current-process) #f)
               #f
               )
             )
           )
          
          ((eq? (-> obj status) 'dead)
           'dead)
          )
        )
      )
    *kernel-context*
    )
  
  ;; todo, remove this and replace it with the rest of the kernel dispatcher.
  (set! *listener-function* (the (function object) #f))
  )

(define-extern inspect-process-tree (function process-tree int int symbol process-tree))
(defun inspect-process-tree ((obj process-tree) (level int) (mask int) (detail symbol))
  "Debug print a pocess-tree"
  (print-tree-bitmask mask (+ 0 level))
  
  ;; print us
  (cond
    (detail
      (format #t "__________________~%")
      ;; this is here, but I removed it because it prints at the wrong indent and looks weird.
      ;(format #t "~S~A~%" (if (zero? level) "" "+---") obj)
      (protect (*print-column*)
               (set! *print-column* (the binteger (* level 4)))
               (inspect obj)
               )
      )
    (else
      (format #t "~S~A~%" (if (zero? level) "" "+---") obj)
      )
    )
  
  ;; print our children
  (let ((child (-> obj child)))
    (while child
      (inspect-process-tree (-> child) (+ level 1) (if (not (-> (-> child) brother)) mask (logior mask (ash 1 (+ 1 level)))) detail)
      (set! child (-> (-> child) brother))
      )
    )
  obj
  )

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stack Frame Stuff (TODO)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 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"
;   (declare (asm-func object)
;            (print-asm)
;            )
  
;   (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 uint)
;          (s3 :reg r11 :type uint)
;          (s4 :reg r12 :type uint)
;          (a0 :reg rdi :type uint)
;          (a1 :reg rsi :type uint)
;          (a2 :reg rdx :type uint)
;          (a3 :reg rcx :type uint)
;          (a4 :reg r8 :type uint)
;          (a5 :reg r9 :type uint)
;          (a6 :reg r10 :type uint)
;          (a7 :reg r11 :type uint)
;          ) 
        
;         ;; we treat the allocation as an address.
;         (let ((obj (the catch-frame (&+ allocation *gtype-basic-offset*))))
;           ;; setup catch frame
;           (set! (-> obj type) type-to-make)
;           (set! (-> obj name) name)
;           ;; get the return address
;           (.pop temp)
;           (.push temp)
;           ;; make it a GOAL address so it fits in 32 bitys
;           (.sub temp off)
;           ;; store it
;           (set! (-> obj ra) (the int temp))
          
;           ;; todo, do we need a stack offset here?
;           (set! temp sp)
;           (.sub temp off)
;           (set! (-> obj sp) (the int sp))
          
;           ;; back up registers
;           (.mov :color #f temp s0)
;           (set-u128-as-u64! (-> obj rreg 0) temp)
;           (.mov :color #f temp s1)
;           (set-u128-as-u64! (-> obj rreg 1) temp)
;           (.mov :color #f temp s2)
;           (set-u128-as-u64! (-> obj rreg 2) temp)
;           (.mov :color #f temp s3)
;           (set-u128-as-u64! (-> obj rreg 3) temp)
;           (.mov :color #f temp s4)
;           (set-u128-as-u64! (-> obj rreg 4) temp)
;           ;; todo save fprs
          
;           ;; push this stack frame
;           (set! (-> obj next) (-> pp stack-frame-top))
;           (set! (-> pp stack-frame-top) obj)
          
;           (let ((ret ((the-super-u64-fucntion func)
;                        ;(-> param-block 0)
;                        (-> param-block)
;                        ;(-> param-block 1)
;                        (-> (&+ param-block 8))
;                        (-> (&+ param-block 16))
;                        (-> (&+ param-block 24))
;                        ;(-> (&+ param-block 32))
;           ;             (-> param-block 5)
;                       ))
;                 )
            
;           ;   (set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
;             )
;           )
;         )
;   ;; the code in here may throw at any point in time, without properly resetting saved registers.
;   ;; so we should save them ourself.
  
;   (the object #f)
;   )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tree Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun change-parent ((obj process-tree) (new-parent process-tree))
  "Make obj a child of new-parent"
  (let ((parent (-> obj parent)))
    ;; parent is a ppointer.
    
    ;; need to remove obj from its current parent
    (when parent
      (let ((proc (-> (-> parent) child)))
        (if (eq? (as-process proc) obj)
            ;; case where we're the first child is easy!
            (set! (-> (-> parent) child) (-> obj brother))
            ;; otherwise, look through brothers to find us.
            (begin
              (while (not (eq? (as-process (-> (-> proc) brother)) obj))
                (set! proc (-> (-> proc) brother))
                )
              ;; ok, got us, splice out of list.
              (set! (-> (-> proc) brother) (-> obj brother))
              )
            )
        )
      )
    
    ;; add to new parent
    (set! (-> obj parent) (-> new-parent ppointer))
    (set! (-> obj brother) (-> new-parent child))
    (set! (-> new-parent child) (-> obj ppointer))
    obj
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(let ((obj (define *listener-process* (new 'global 'process 'listener 2048))))
  (set! (-> obj status) 'ready)
  (set! (-> obj pid) 1)
  ;; allocation symbol is actually process, but it's ignored so this is ok for now.
  (set! (-> obj main-thread) (new 'global 'cpu-thread obj 'main 256 *kernel-dram-stack*))
  )

;; these are unknown
(define *null-process* (new 'global 'process 'listener 16))
(define *vis-boot* #f)

;; a few pools of fixed size processes that are shared.
(define *16k-dead-pool* (new 'global 'dead-pool 1 (* 16 1024) '*16k-dead-pool*))
(define *8k-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*8k-dead-pool*))
(define *4k-dead-pool* (new 'global 'dead-pool 4 (* 4 1024) '*4k-dead-pool*))

;; some very important process pools
(define *target-dead-pool* (new 'global 'dead-pool 1 (* 48 1024) '*target-dead-pool*))
(define *camera-dead-pool* (new 'global 'dead-pool 7 (* 4 1024) '*camera-dead-pool*))
(define *camera-master-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*camera-master-dead-pool*))

(if *debug-segment*
  (define *debug-dead-pool* (new 'debug 'dead-pool-heap '*debug-dead-pool* 768 (* 1024 1024)))
  )

(define *nk-dead-pool* (new 'global 'dead-pool-heap '*nk-dead-pool* 768 PROCESS_HEAP_SIZE))
(define *default-dead-pool* (the dead-pool *nk-dead-pool*))
(define *pickup-dead-pool* (the dead-pool *nk-dead-pool*))

;; todo dead pool list

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Temp Hacks
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; (defun kernel-dispatcher ()
;   "Kernel Dispatcher Function. This gets called from the main loop in kboot.cpp's KernelCheckAndDispatch"
  
;   ;; check if we have a new listener function to run
;   (when *listener-function*
;     ;; we do! enable method-set for debug purposes
;     (+! *enable-method-set* 1)
    
;     ;; execute and print result
;     (let ((result (*listener-function*)))
;       (format #t "~D~%" result)
;       )
;     (+! *enable-method-set* -1)
    
;     ;; clear the pending function.
;     (set! *listener-function* (the (function object) #f))
;     )
;   )