mirror of
https://github.com/open-goal/jak-project.git
synced 2024-10-20 21:27:52 -04:00
2513 lines
82 KiB
Common Lisp
2513 lines
82 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; name: gkernel.gc
|
|
;; name in dgo: gkernel
|
|
;; dgos: KERNEL
|
|
|
|
;; og:ignore-errors:true
|
|
;; og:ignore-form:defun kernel-dispatcher
|
|
|
|
;; forward declared stuff
|
|
(define-extern *kernel-clock* clock)
|
|
(define-extern *debug-dead-pool* dead-pool-heap)
|
|
(define-extern *null-process* process)
|
|
(define-extern *vis-boot* symbol)
|
|
(define-extern *listener-process* process)
|
|
(define-extern *active-pool* process-tree)
|
|
(define-extern *default-level* level)
|
|
|
|
(define-extern change-parent (function process-tree process-tree process-tree))
|
|
(define-extern search-process-tree (function process-tree (function process-tree object) process-tree))
|
|
(define-extern iterate-process-tree (function process-tree (function object object) kernel-context object))
|
|
(define-extern execute-process-tree (function process-tree (function object object) kernel-context object))
|
|
(define-extern inspect-process-tree (function process-tree int int symbol process-tree))
|
|
(define-extern process-disconnect (function process int))
|
|
|
|
;; DECOMP BEGINS
|
|
|
|
;; Version constants
|
|
(define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*)))
|
|
(define *irx-version* (the-as binteger #x200000))
|
|
|
|
;; Boot options
|
|
(define *kernel-boot-mode* 'listener)
|
|
(define *kernel-boot-level* #f)
|
|
(define *use-old-listener-print* #f)
|
|
|
|
;; Stats
|
|
(define *deci-count* 0)
|
|
(define *last-loado-length* 0)
|
|
(define *last-loado-global-usage* 0)
|
|
(define *last-loado-debug-usage* 0)
|
|
|
|
(defmethod relocate object ((obj object) (arg0 int))
|
|
"Most general relocate method."
|
|
obj
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;
|
|
;; Package
|
|
;;;;;;;;;;;;;;;;;;
|
|
|
|
(define *kernel-packages* '())
|
|
|
|
(defun load-package ((arg0 string) (arg1 kheap))
|
|
"Load a package by name to the given heap."
|
|
(when (not (nmember arg0 *kernel-packages*))
|
|
(kmemopen global arg0)
|
|
(dgo-load arg0 arg1 (link-flag output-load-msg output-load-true-msg execute-login print-login) #x200000)
|
|
(set! *kernel-packages* (cons arg0 *kernel-packages*))
|
|
(kmemclose)
|
|
*kernel-packages*
|
|
)
|
|
)
|
|
|
|
(defun unload-package ((arg0 string))
|
|
"Mark a package as unloaded."
|
|
(let ((v1-0 (nmember arg0 *kernel-packages*)))
|
|
(if v1-0
|
|
(set! *kernel-packages* (delete! (car v1-0) *kernel-packages*))
|
|
)
|
|
)
|
|
*kernel-packages*
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;
|
|
;; Kernel Globals
|
|
;;;;;;;;;;;;;;;;;;
|
|
|
|
;; the global kernel-context
|
|
(define *kernel-context*
|
|
(new 'static 'kernel-context
|
|
:prevent-from-run (process-mask execute sleep)
|
|
:next-pid 3
|
|
:current-process #f
|
|
:relocating-process #f
|
|
:low-memory-message #t
|
|
)
|
|
)
|
|
|
|
;; the main execution stack that's not on the scratchpad
|
|
;; (define *canary-1* (the-as (pointer uint64) (malloc 'global 8)))
|
|
(define *dram-stack* (the-as (pointer uint8) (malloc 'global DPROCESS_STACK_SIZE)))
|
|
;; (define *canary-2* (the-as (pointer uint64) (malloc 'global 8)))
|
|
|
|
;; DECOMP DEVIATION
|
|
;; the top of the stack.
|
|
(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE))
|
|
;; DECOMP DEVIATION
|
|
|
|
;; the top of the scratchpad stack
|
|
(set! (-> *kernel-context* fast-stack-top) (the-as pointer #x70004000))
|
|
|
|
(define *null-kernel-context* (new 'static 'kernel-context))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PC Port Scratchpad
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; DECOMP DEVIATION
|
|
(#cond
|
|
(PC_PORT
|
|
;; we'll create a fake scratchpad:
|
|
;; make sure the scratchpad is 64kb aligned, and make it 32 kB so we can big stacks on it.
|
|
;; some (partially buggy) code in generic tie relies on 64 kB alignment.
|
|
(let* ((mem (new 'global 'array 'uint8 (* 128 1024)))
|
|
)
|
|
(define *fake-scratchpad-data* (the pointer (align-n mem (* 64 1024))))
|
|
)
|
|
|
|
;; use the same memory for the scratchpad stacks.
|
|
;; defining it as a separate thing so we can split them for debugging stack corruption easily.
|
|
(define *fake-scratchpad-stack* *fake-scratchpad-data*)
|
|
;; (define *canary-3* (the-as (pointer uint64) (malloc 'global 8)))
|
|
|
|
(defmacro scratchpad-start ()
|
|
"Get the start of the scratchpad. At least 64kB aligned."
|
|
'*fake-scratchpad-data*
|
|
)
|
|
)
|
|
(else
|
|
(defmacro scratchpad-start ()
|
|
#x70000000
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro scratchpad-end ()
|
|
"Get the end of the scratchpad memory"
|
|
`(&+ (scratchpad-start) (* 16 1024))
|
|
)
|
|
|
|
(defmacro in-scratchpad? (x)
|
|
"Is the given address in the scratchpad?"
|
|
`(and
|
|
(>= (the-as int ,x) (scratchpad-start))
|
|
(< (the-as int ,x) (scratchpad-end))
|
|
)
|
|
)
|
|
;; DECOMP DEVIATION
|
|
|
|
;;;;;;;;;;;;;
|
|
;; Thread
|
|
;;;;;;;;;;;;;
|
|
|
|
(defmethod delete thread ((obj thread))
|
|
"Restore the previous thread as the top-thread."
|
|
;; make sure we aren't actually trying to delete the main thread.
|
|
(when (= obj (-> obj process main-thread))
|
|
(break!)
|
|
)
|
|
(set! (-> obj process top-thread) (the-as cpu-thread (-> obj previous)))
|
|
(none)
|
|
)
|
|
|
|
(defmethod print thread ((obj thread))
|
|
(format #t "#<~A ~S of ~S pc: #x~X @ #x~X>" (-> obj type) (-> obj name) (-> obj process name) (-> obj pc) obj)
|
|
obj
|
|
)
|
|
|
|
(defmethod stack-size-set! thread ((obj thread) (arg0 int))
|
|
"Modify the backup stack size of a thread. Must be called from the main thread, before any
|
|
allocations have been done on the process heap."
|
|
(let ((a2-0 (-> obj process)))
|
|
(cond
|
|
((!= obj (-> a2-0 main-thread))
|
|
(format 0 "ERROR: illegal attempt change stack size of ~A when the main-thread is not the top-thread.~%" a2-0)
|
|
)
|
|
((= (-> obj stack-size) arg0)
|
|
)
|
|
((= (-> a2-0 heap-cur) (+ (+ (-> obj stack-size) -4 (-> obj type size)) (the-as int obj)))
|
|
(set! (-> a2-0 heap-cur) (the-as pointer (+ (+ arg0 -4 (-> obj type size)) (the-as int obj))))
|
|
(set! (-> obj stack-size) arg0)
|
|
)
|
|
(else
|
|
(format 0 "ERROR: illegal attempt change stack size of ~A after more heap allocation has occured.~%" a2-0)
|
|
)
|
|
)
|
|
)
|
|
(none)
|
|
)
|
|
|
|
(defmethod new cpu-thread ((allocation symbol) (type-to-make type) (parent-process process) (name symbol) (arg2 int) (stack-top pointer))
|
|
"Create a new CPU thread. If there is no main thread, it will allocate the main thread on the process.
|
|
If there is already a main thread, it will allocate a temporary thread on the given stack.
|
|
Sets the thread as the top-thread of the process
|
|
This is a special new method which ignores the allocation symbol.
|
|
The stack-top is for the execution stack.
|
|
The stack-size is for the backup stack (applicable for main thread only)"
|
|
(let ((v0-0 (cond
|
|
((-> parent-process top-thread)
|
|
;; this is just a temporary thread, throw the thread on the bottom of the stack
|
|
(the cpu-thread (&+ stack-top (- PROCESS_STACK_SIZE) *gtype-basic-offset*))
|
|
)
|
|
(else
|
|
;; this is the main thread, allocate it from the process heap.
|
|
(let ((v1-2 (logand -16 (&+ (-> parent-process heap-cur) 15))))
|
|
(set! (-> parent-process heap-cur) (&+ (&+ v1-2 (-> type-to-make size)) arg2))
|
|
(the cpu-thread (&+ v1-2 4))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> v0-0 type) type-to-make)
|
|
(set! (-> v0-0 name) name)
|
|
(set! (-> v0-0 process) parent-process)
|
|
(set! (-> v0-0 sp) stack-top)
|
|
(set! (-> v0-0 stack-top) stack-top)
|
|
(set! (-> v0-0 previous) (-> parent-process top-thread))
|
|
(set! (-> parent-process top-thread) v0-0)
|
|
(set! (-> v0-0 suspend-hook) (method-of-object v0-0 thread-suspend))
|
|
(set! (-> v0-0 resume-hook) (method-of-object v0-0 thread-resume))
|
|
(set! (-> v0-0 stack-size) arg2)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defmethod asize-of cpu-thread ((obj cpu-thread))
|
|
"Get the size in memory of a cpu-thread."
|
|
(the-as int (+ (-> obj type size) (-> obj stack-size)))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;
|
|
;; Process
|
|
;;;;;;;;;;;;;;;
|
|
|
|
(defbehavior remove-exit process ()
|
|
"Remove a single stack frame.
|
|
This can be used to skip an exit of a state, but it's a bit of a hack."
|
|
(if (-> self stack-frame-top)
|
|
(set! (-> self stack-frame-top) (-> self stack-frame-top next))
|
|
)
|
|
0
|
|
(none)
|
|
)
|
|
|
|
;; decomp deviation
|
|
(defun-debug stream<-process-mask ((arg0 object) (arg1 process-mask))
|
|
"Print a process mask."
|
|
(bit-enum->string process-mask arg1 arg0)
|
|
arg1
|
|
)
|
|
;; decomp deviation
|
|
|
|
(define *master-mode* 'game)
|
|
(define *pause-lock* #f)
|
|
|
|
(defmethod print process-tree ((obj process-tree))
|
|
"Print a process tree."
|
|
(format #t "#<~A ~S @ #x~X>" (-> obj type) (-> obj name) obj)
|
|
obj
|
|
)
|
|
|
|
(defmethod new process-tree ((allocation symbol) (type-to-make type) (arg0 string))
|
|
"Allocate a new process-tree with the given name."
|
|
(let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> v0-0 name) arg0)
|
|
(set! (-> v0-0 mask) (process-mask process-tree))
|
|
(set! (-> v0-0 clock) *kernel-clock*)
|
|
(set! (-> v0-0 parent) (the-as (pointer process-tree) #f))
|
|
(set! (-> v0-0 brother) (the-as (pointer process-tree) #f))
|
|
(set! (-> v0-0 child) (the-as (pointer process-tree) #f))
|
|
(set! (-> v0-0 self) v0-0)
|
|
(set! (-> v0-0 ppointer) (the-as (pointer process) (&-> v0-0 self)))
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defmethod inspect process-tree ((obj process-tree))
|
|
"Inspect a process-tree"
|
|
(format #t "[~8x] ~A~%" obj (-> obj type))
|
|
(format #t "~Tname: ~S~%" (-> obj name))
|
|
(format #t "~1Tmask: #x~X : (process-mask " (-> obj mask))
|
|
(stream<-process-mask #t (-> obj mask))
|
|
(format #t ")~%")
|
|
(format #t "~Tclock: ~A~%" (-> obj clock))
|
|
(format #t "~Tparent: ~A~%" (ppointer->process (-> obj parent)))
|
|
(format #t "~Tbrother: ~A~%" (ppointer->process (-> obj brother)))
|
|
(format #t "~Tchild: ~A~%" (ppointer->process (-> obj child)))
|
|
obj
|
|
)
|
|
|
|
(defmethod new process ((allocation symbol) (type-to-make type) (arg0 string) (arg1 int))
|
|
"Allocate or initialize a process."
|
|
;; check if we got a symbol (for a heap) or just a plain address.
|
|
(let ((v0-0 (if (logtest? (the-as int allocation) 1)
|
|
(object-new allocation type-to-make (the-as int (+ (-> process size) arg1))) ;; allocate on heap
|
|
(the process (+ (the-as int allocation) 4)) ;; just use it as an address, do an in-place initialization.
|
|
)
|
|
)
|
|
)
|
|
(set! (-> v0-0 name) arg0)
|
|
(set! (-> v0-0 clock) *kernel-clock*)
|
|
(set! (-> v0-0 status) 'dead)
|
|
(set! (-> v0-0 pid) 0)
|
|
(set! (-> v0-0 pool) #f)
|
|
(set! (-> v0-0 allocated-length) arg1)
|
|
(set! (-> v0-0 top-thread) #f)
|
|
(set! (-> v0-0 main-thread) #f)
|
|
(let ((v1-6 (-> v0-0 stack)))
|
|
(set! (-> v0-0 heap-cur) v1-6)
|
|
(set! (-> v0-0 heap-base) v1-6)
|
|
)
|
|
(set! (-> v0-0 heap-top)
|
|
(&-> v0-0 stack (-> v0-0 allocated-length))
|
|
)
|
|
(set! (-> v0-0 stack-frame-top) (the-as stack-frame (-> v0-0 heap-top))) ;; bug, probably kheap overlapping this.
|
|
(set! (-> v0-0 stack-frame-top) #f)
|
|
(set! (-> v0-0 state) #f)
|
|
(set! (-> v0-0 next-state) #f)
|
|
(set! (-> v0-0 entity) #f)
|
|
(set! (-> v0-0 level) #f)
|
|
(set! (-> v0-0 trans-hook) #f)
|
|
(set! (-> v0-0 post-hook) #f)
|
|
(set! (-> v0-0 event-hook) #f)
|
|
(set! (-> v0-0 parent) (the-as (pointer process-tree) #f))
|
|
(set! (-> v0-0 brother) (the-as (pointer process-tree) #f))
|
|
(set! (-> v0-0 child) (the-as (pointer process-tree) #f))
|
|
(set! (-> v0-0 self) v0-0)
|
|
(set! (-> v0-0 ppointer) (the-as (pointer process) (&-> v0-0 self)))
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun inspect-process-heap ((obj process))
|
|
"Inspect each object on the process heap."
|
|
(let ((ptr (&+ (-> obj heap-base) *gtype-basic-offset*))) ; point to first basic
|
|
;; loop over objects
|
|
(while (< (the int ptr) (the int (-> obj heap-cur)))
|
|
;; inspect the object
|
|
(inspect (the basic ptr))
|
|
;; seek to the next object on the heap.
|
|
(&+! ptr (the int (align16 (asize-of (the basic ptr)))))
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defmethod inspect process ((obj process))
|
|
"Inspect process and all objects on the heap.. Autogenerated proces inspects will eventually call this one."
|
|
(format #t "[~8x] ~A~%" obj (-> obj type))
|
|
(format #t "~Tname: ~S~%" (-> obj name))
|
|
(format #t "~1Tmask: #x~X : (process-mask " (-> obj mask))
|
|
(stream<-process-mask #t (-> obj mask))
|
|
(format #t ")~%")
|
|
(format #t "~Tclock: ~A~%" (-> obj clock))
|
|
(format #t "~Tstatus: ~A~%" (-> obj status))
|
|
(format #t "~Tmain-thread: ~A~%" (-> obj main-thread))
|
|
(format #t "~Ttop-thread: ~A~%" (-> obj top-thread))
|
|
(format #t "~Tentity: ~A~%" (-> obj entity))
|
|
(format #t "~Tlevel: ~A~%" (-> obj level))
|
|
(format #t "~Tstate: ~A~%" (-> obj state))
|
|
(format #t "~Tnext-state: ~A~%" (-> obj next-state))
|
|
(format #t "~Ttrans-hook: ~A~%" (-> obj trans-hook))
|
|
(format #t "~Tpost-hook: ~A~%" (-> obj post-hook))
|
|
(format #t "~Tevent-hook: ~A~%" (-> obj event-hook))
|
|
(format #t "~Tparent: ~A~%" (ppointer->process (-> obj parent)))
|
|
(format #t "~Tbrother: ~A~%" (ppointer->process (-> obj brother)))
|
|
(format #t "~Tchild: ~A~%" (ppointer->process (-> obj child)))
|
|
(format #t "~Tconnection-list: ~`connectable`P~%" (-> obj connection-list))
|
|
(format #t "~Tstack-frame-top: ~A~%" (-> obj stack-frame-top))
|
|
(format #t "~Theap-base: #x~X~%" (-> obj heap-base))
|
|
(format #t "~Theap-top: #x~X~%" (-> obj heap-top))
|
|
(format #t "~Theap-cur: #x~X~%" (-> obj heap-cur))
|
|
(let ((s5-0 *print-column*))
|
|
(set! *print-column* (+ *print-column* *tab-size*))
|
|
(format #t "----~%")
|
|
(inspect-process-heap obj)
|
|
(format #t "----~%")
|
|
(set! *print-column* s5-0)
|
|
)
|
|
(format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
|
|
(format #t "~Tstack[~D] @ #x~X~%" (-> obj allocated-length) (-> obj stack))
|
|
obj
|
|
)
|
|
|
|
(defmethod asize-of process ((obj process))
|
|
"Get the size in memory of a process."
|
|
(the-as int (+ (-> process size) (-> obj allocated-length)))
|
|
)
|
|
|
|
(defmethod print process ((obj process))
|
|
"Print a process."
|
|
|
|
;; new: for jak 2, they don't print garbage stack/heap sizes when the process isn't
|
|
;; activated yet.
|
|
(cond
|
|
((and (-> obj top-thread) (!= (-> obj status) 'dead))
|
|
(format #t "#<~A ~S ~A :state ~S "
|
|
(-> obj type)
|
|
(-> obj name)
|
|
(-> obj status)
|
|
(if (-> obj state) (-> obj state name))
|
|
)
|
|
(format #t ":stack ~D/~D :heap ~D/~D @ #x~X>"
|
|
(&- (-> obj top-thread stack-top) (the-as uint (-> obj top-thread sp)))
|
|
(-> obj main-thread stack-size)
|
|
(- (-> obj allocated-length) (&- (-> obj heap-top) (the-as uint (-> obj heap-cur))))
|
|
(-> obj allocated-length)
|
|
obj
|
|
)
|
|
)
|
|
(else
|
|
(format #t "#<~A ~S ~A :state ~S @ #x~X"
|
|
(-> obj type)
|
|
(-> obj name)
|
|
(-> obj status)
|
|
(if (-> obj state)
|
|
(-> obj state name)
|
|
)
|
|
obj
|
|
)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
;; decomp deviation
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Context Suspend And Resume - Kernel
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; the following functions are used for going from the kernel to threads and back.
|
|
;; saved registers: rbx, rbp, r10, r11, r12
|
|
|
|
;; DANGER - THE KERNEL DOES NOT SAVE ITS FLOATING POINT CONTEXT!!!!
|
|
|
|
;; we use this to store a GOAL pointer to the kernel's stack pointer when executing user code.
|
|
;; to get back to the kernel, we use this global symbol.
|
|
(define-extern *kernel-sp* pointer)
|
|
|
|
(defun return-from-thread ()
|
|
"Context switch to the saved kernel context now.
|
|
This is intended to be jumped to with the ret instruction (return trampoline)
|
|
at the end of a normal function, so this should preserve rax.
|
|
To make sure this happens, all ops should be asm ops and we should have no
|
|
GOAL expressions."
|
|
(declare (asm-func none)
|
|
;(print-asm)
|
|
)
|
|
(rlet ((sp :reg rsp :type uint)
|
|
(off :reg r15 :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type uint)
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
)
|
|
;; get the kernel stack pointer as a GOAL pointer (won't use a temp reg)
|
|
(.load-sym :sext #f sp *kernel-sp*)
|
|
;; convert it back to a real pointer
|
|
(.add sp off)
|
|
|
|
;; restore saved registers...
|
|
;; without coloring system because this is "cheating" and modifying saved registers without backing up.
|
|
(.pop :color #f s4)
|
|
(.pop :color #f s3)
|
|
(.pop :color #f s2)
|
|
(.pop :color #f s1)
|
|
(.pop :color #f s0)
|
|
;; return to the kernel function that called the user code
|
|
;; rax should still contain the return value.
|
|
(.ret)
|
|
)
|
|
)
|
|
|
|
(defun return-from-thread-dead ()
|
|
"Like return from thread, but we clean up our process with deactivate first.
|
|
The return register is not preserved here, instead we return the value of deactivate"
|
|
(declare (asm-func none)
|
|
;(print-asm)
|
|
)
|
|
(rlet ((pp :reg r13 :type process)
|
|
(sp :reg rsp :type uint)
|
|
(off :reg r15 :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type uint)
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
)
|
|
|
|
;; first call the deactivate method.
|
|
(deactivate pp)
|
|
;; get the kernel stack pointer as a GOAL pointer
|
|
(.load-sym :sext #f sp *kernel-sp*)
|
|
;; convert it back to a real pointer
|
|
(.add sp off)
|
|
|
|
;; restore saved registers...
|
|
;; without coloring system because this is "cheating".
|
|
(.pop :color #f s4)
|
|
(.pop :color #f s3)
|
|
(.pop :color #f s2)
|
|
(.pop :color #f s1)
|
|
(.pop :color #f s0)
|
|
;; return to the kernel function that called the user code
|
|
(.ret)
|
|
)
|
|
)
|
|
|
|
(defmacro abandon-thread ()
|
|
;; abandon this one too.
|
|
;; NOTE - this is different from GOAL.
|
|
;; GOAL installs this as the return address for this function and returns normally.
|
|
;; but we don't because I don't have an easy way to find where to stick this.
|
|
;; I can't see how this makes a difference, as all non-main threads seem
|
|
;; temporary, but if this turns out to be false, we will need to change this.
|
|
`(rlet ((temp)
|
|
(off :reg r15 :type uint :reset-here #t))
|
|
(.mov temp return-from-thread) ;; could probably just call this...
|
|
(.add temp off)
|
|
(.push temp)
|
|
(.ret)
|
|
)
|
|
)
|
|
|
|
(defun reset-and-call ((obj thread) (func function))
|
|
"Make the given thread the top thread, reset the stack, and call the function.
|
|
Sets up a return trampoline so when the function returns it will return to the
|
|
kernel context. Will NOT deactivate on return, so this is intended for temporary threads.
|
|
NOTE: this should only be done from the kernel, running on the
|
|
kernel's stack."
|
|
(declare (asm-func object)
|
|
)
|
|
|
|
(rlet ((pp :reg r13 :type process)
|
|
(sp :reg rsp :type uint)
|
|
(off :reg r15 :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type uint)
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
(temp :reg rax :type uint)
|
|
)
|
|
|
|
;; set up the process pointer
|
|
(set! pp (-> obj process))
|
|
;; mark the process as running and set its top thread
|
|
(set! (-> pp status) 'running)
|
|
(set! (-> pp top-thread) (the cpu-thread obj))
|
|
|
|
;; save the current kernel regs
|
|
(.push :color #f s0)
|
|
(.push :color #f s1)
|
|
(.push :color #f s2)
|
|
(.push :color #f s3)
|
|
(.push :color #f s4)
|
|
|
|
;; make rsp a GOAL pointer
|
|
(.sub sp off)
|
|
;; and store it
|
|
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
|
|
|
|
;; setup the rsp for the new thread
|
|
(set! sp (the uint (-> obj stack-top)))
|
|
(.add sp off)
|
|
|
|
;; push the return trampoline to the stack for the user code to return to
|
|
(set! temp (the uint return-from-thread))
|
|
(.add temp off)
|
|
(.push temp) ;; stack now 16 + 8 aligned
|
|
;; and call the function!
|
|
(.add func off)
|
|
(.jr func)
|
|
)
|
|
)
|
|
|
|
(defmethod thread-suspend cpu-thread ((unused cpu-thread))
|
|
"Suspend the thread and return to the kernel."
|
|
|
|
(declare (asm-func none))
|
|
|
|
;; we begin this function with the thread object in pp.
|
|
;; not sure why we do this, maybe at one point suspending didn't clobber
|
|
;; temp registers?
|
|
(rlet ((obj :reg r13 :type cpu-thread)
|
|
(temp :reg rax :type uint)
|
|
(off :reg r15 :type uint)
|
|
(sp :reg rsp :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type uint)
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
|
|
(xmm8 :reg xmm8 :class fpr)
|
|
(xmm9 :reg xmm9 :class fpr)
|
|
(xmm10 :reg xmm10 :class fpr)
|
|
(xmm11 :reg xmm11 :class fpr)
|
|
(xmm12 :reg xmm12 :class fpr)
|
|
(xmm13 :reg xmm13 :class fpr)
|
|
(xmm14 :reg xmm14 :class fpr)
|
|
(xmm15 :reg xmm15 :class fpr)
|
|
)
|
|
|
|
;; get the return address pushed by "call" in the suspend.
|
|
(.pop temp)
|
|
;; convert to a GOAL address
|
|
(.sub temp off)
|
|
;; store return address in thread
|
|
(set! (-> obj pc) (the pointer temp))
|
|
|
|
;; convert our stack pointer to a GOAL address
|
|
(.sub sp off)
|
|
;; store in thread.
|
|
(set! (-> obj sp) (the pointer sp))
|
|
|
|
;; back up registers
|
|
(.mov :color #f temp s0)
|
|
(set! (-> obj rreg 0) temp)
|
|
(.mov :color #f temp s1)
|
|
(set! (-> obj rreg 1) temp)
|
|
(.mov :color #f temp s2)
|
|
(set! (-> obj rreg 2) temp)
|
|
(.mov :color #f temp s3)
|
|
(set! (-> obj rreg 3) temp)
|
|
(.mov :color #f temp s4)
|
|
(set! (-> obj rreg 4) temp)
|
|
|
|
;; back up fprs
|
|
(.mov :color #f temp xmm8)
|
|
(set! (-> obj freg 0) (the-as float temp))
|
|
(.mov :color #f temp xmm9)
|
|
(set! (-> obj freg 1) (the-as float temp))
|
|
(.mov :color #f temp xmm10)
|
|
(set! (-> obj freg 2) (the-as float temp))
|
|
(.mov :color #f temp xmm11)
|
|
(set! (-> obj freg 3) (the-as float temp))
|
|
(.mov :color #f temp xmm12)
|
|
(set! (-> obj freg 4) (the-as float temp))
|
|
(.mov :color #f temp xmm13)
|
|
(set! (-> obj freg 5) (the-as float temp))
|
|
(.mov :color #f temp xmm14)
|
|
(set! (-> obj freg 6) (the-as float temp))
|
|
(.mov :color #f temp xmm15)
|
|
(set! (-> obj freg 7) (the-as float temp))
|
|
|
|
|
|
|
|
;; get our process
|
|
(let ((proc (-> obj process)))
|
|
(when (> (process-stack-used proc) (-> obj stack-size))
|
|
(break) ;; too much stack has been used and we can't suspend!
|
|
;; if you hit this, try with DEBUG_PRINT_SUSPEND_FAIL set to #t (see gkernel-h.gc)
|
|
;; it will print more info before reaching here.
|
|
)
|
|
|
|
;; mark the process as suspended and copy the stack
|
|
(set! (-> proc status) 'suspended)
|
|
(let ((cur (the (pointer uint64) (-> obj stack-top)))
|
|
(save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
|
|
)
|
|
(while (> (the int cur) (the int sp))
|
|
(set! cur (the (pointer uint64) (&- cur 8)))
|
|
(set! save (the (pointer uint64) (&- save 8)))
|
|
(set! (-> save) (-> cur))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; actually setting pp to 0
|
|
(set! obj (the cpu-thread 0))
|
|
|
|
;; get the kernel stack pointer as a GOAL pointer
|
|
(.load-sym :sext #f sp *kernel-sp*)
|
|
;; convert it back to a real pointer
|
|
(.add sp off)
|
|
|
|
;; restore saved registers...
|
|
;; without coloring system because this is "cheating".
|
|
(.pop :color #f s4)
|
|
(.pop :color #f s3)
|
|
(.pop :color #f s2)
|
|
(.pop :color #f s1)
|
|
(.pop :color #f s0)
|
|
;; return to the kernel function that called the user code
|
|
(.ret)
|
|
)
|
|
(none)
|
|
)
|
|
|
|
(defmethod thread-resume cpu-thread ((thread-to-resume cpu-thread))
|
|
"Resume a suspended thread. Call this from the kernel only.
|
|
This is also used to start a thread initialized with set-to-run.
|
|
As a result of MIPS/x86 differences, there is a hack for this."
|
|
(declare (asm-func none)
|
|
;;(print-asm)
|
|
)
|
|
|
|
(rlet ((obj :reg r13 :type cpu-thread)
|
|
(temp :reg rax :type uint)
|
|
(off :reg r15 :type uint)
|
|
(sp :reg rsp :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type uint)
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
(a4 :reg r8 :type uint)
|
|
(a5 :reg r9 :type uint)
|
|
|
|
(temp-float :reg xmm0 :class fpr)
|
|
(xmm8 :reg xmm8 :class fpr)
|
|
(xmm9 :reg xmm9 :class fpr)
|
|
(xmm10 :reg xmm10 :class fpr)
|
|
(xmm11 :reg xmm11 :class fpr)
|
|
(xmm12 :reg xmm12 :class fpr)
|
|
(xmm13 :reg xmm13 :class fpr)
|
|
(xmm14 :reg xmm14 :class fpr)
|
|
(xmm15 :reg xmm15 :class fpr)
|
|
)
|
|
|
|
;; save the current kernel regs
|
|
(.push :color #f s0)
|
|
(.push :color #f s1)
|
|
(.push :color #f s2)
|
|
(.push :color #f s3)
|
|
(.push :color #f s4)
|
|
|
|
;; make rsp a GOAL pointer
|
|
(.sub sp off)
|
|
;; and store it
|
|
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
|
|
|
|
;; temp, stash thread in process-pointer
|
|
(set! obj thread-to-resume)
|
|
|
|
;; set stack pointer for the thread. leave it as a GOAL pointer for now..
|
|
(set! sp (the uint (-> obj sp)))
|
|
|
|
;; restore the stack (sp is a GOAL pointer)
|
|
(let ((cur (the (pointer uint64) (-> obj stack-top)))
|
|
(restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
|
|
)
|
|
(while (> (the int cur) (the int sp))
|
|
(set! cur (the (pointer uint64) (&- cur 8)))
|
|
(set! restore (the (pointer uint64) (&- restore 8)))
|
|
(set! (-> cur) (-> restore))
|
|
)
|
|
)
|
|
|
|
;; offset sp after we're done using it as a GOAL pointer.
|
|
(.add sp off)
|
|
|
|
;; setup process
|
|
(set! (-> (-> obj process) top-thread) obj)
|
|
(set! (-> (-> obj process) status) 'running)
|
|
|
|
;; restore reg
|
|
(set! temp (-> obj rreg 0))
|
|
(.mov :color #f s0 temp)
|
|
(set! temp (-> obj rreg 1))
|
|
(.mov :color #f s1 temp)
|
|
(set! temp (-> obj rreg 2))
|
|
(.mov :color #f s2 temp)
|
|
(set! temp (-> obj rreg 3))
|
|
(.mov :color #f s3 temp)
|
|
(set! temp (-> obj rreg 4))
|
|
(.mov :color #f s4 temp)
|
|
(set! temp-float (-> obj freg 0))
|
|
(.mov :color #f xmm8 temp-float)
|
|
(set! temp-float (-> obj freg 1))
|
|
(.mov :color #f xmm9 temp-float)
|
|
(set! temp-float (-> obj freg 2))
|
|
(.mov :color #f xmm10 temp-float)
|
|
(set! temp-float (-> obj freg 3))
|
|
(.mov :color #f xmm11 temp-float)
|
|
(set! temp-float (-> obj freg 4))
|
|
(.mov :color #f xmm12 temp-float)
|
|
(set! temp-float (-> obj freg 5))
|
|
(.mov :color #f xmm13 temp-float)
|
|
(set! temp-float (-> obj freg 6))
|
|
(.mov :color #f xmm14 temp-float)
|
|
(set! temp-float (-> obj freg 7))
|
|
(.mov :color #f xmm15 temp-float)
|
|
|
|
;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
|
|
;; expects to receive 7 values from the cpu thread's rregs.
|
|
;; usually rreg holds saved registers, but on the first resume after
|
|
;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
|
|
|
|
;; We only have 5 saved regs, so we need to cheat and directly pass
|
|
;; two values in other registers
|
|
;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
|
|
;; In the case where we are doing a normal resume, the
|
|
;; compiler should assume that these registers are overwritten anyway.
|
|
(set! temp (-> obj rreg 5))
|
|
(.mov a4 temp)
|
|
(set! temp (-> obj rreg 6))
|
|
(.mov a5 temp)
|
|
|
|
;; get the resume address
|
|
(set! temp (the uint (-> obj pc)))
|
|
(.add temp off)
|
|
|
|
;; setup the process
|
|
(set! obj (the cpu-thread (-> obj process)))
|
|
;; resume!
|
|
(.jr temp)
|
|
(.add a4 a4)
|
|
(.add a5 a5)
|
|
)
|
|
(none)
|
|
)
|
|
;; decomp deviation
|
|
|
|
|
|
(defmethod new dead-pool ((allocation symbol) (type-to-make type) (arg0 int) (arg1 int) (arg2 string))
|
|
"Allocate a tree of dead processes."
|
|
(let ((s3-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> s3-0 name) arg2)
|
|
(set! (-> s3-0 mask) (process-mask process-tree))
|
|
(set! (-> s3-0 parent) (the-as (pointer process-tree) #f))
|
|
(set! (-> s3-0 brother) (the-as (pointer process-tree) #f))
|
|
(set! (-> s3-0 child) (the-as (pointer process-tree) #f))
|
|
(set! (-> s3-0 self) s3-0)
|
|
(set! (-> s3-0 ppointer) (the-as (pointer process) (&-> s3-0 self)))
|
|
(dotimes (s2-1 arg0)
|
|
(let ((s1-0 (-> s3-0 child))
|
|
(v1-5 ((method-of-type process new) allocation process "dead" arg1))
|
|
)
|
|
(set! (-> s3-0 child) (process->ppointer v1-5))
|
|
(set! (-> v1-5 parent) (process->ppointer (the-as process s3-0)))
|
|
(set! (-> v1-5 pool) s3-0)
|
|
(set! (-> v1-5 brother) s1-0)
|
|
)
|
|
)
|
|
s3-0
|
|
)
|
|
)
|
|
|
|
;; decomp deviation
|
|
(defmethod get-process dead-pool ((obj dead-pool) (arg0 type) (arg1 int))
|
|
"Try to get a process from this dead pool. If it fails, try the debug dead pool and complain."
|
|
|
|
;; grab the first child
|
|
(let ((s4-0 (the-as object (-> obj child))))
|
|
(when (and (not (the-as (pointer process-tree) s4-0)) *debug-segment* (!= obj *debug-dead-pool*))
|
|
;; didn't work, but we have the debug dead pool to try
|
|
;; NOTE: this is a type bug here, s4-0 should be (pointer process), but this uses process.
|
|
(set! s4-0 (get-process *debug-dead-pool* arg0 arg1))
|
|
|
|
(if (the-as process s4-0)
|
|
;; that worked. complain.
|
|
(format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
|
|
arg0
|
|
#f ;; (ppointer->process (the-as process s4-0)) bugged in original game
|
|
(-> obj name)
|
|
)
|
|
)
|
|
;; this didn't work right in the original game, just crash here.
|
|
(break)
|
|
)
|
|
(cond
|
|
(s4-0
|
|
;; got a process somehow, set the type and return.
|
|
(set! (-> (the-as (pointer process) s4-0) 0 type) arg0)
|
|
(-> (the-as (pointer process) s4-0) 0)
|
|
)
|
|
(else
|
|
;; didn't work, complain and return #f.
|
|
(format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
|
|
arg0
|
|
(ppointer->process (the-as (pointer process) s4-0))
|
|
(-> obj name)
|
|
)
|
|
(the-as process #f)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
;; decomp deviation
|
|
|
|
(defmethod return-process dead-pool ((obj dead-pool) (arg0 process))
|
|
"Return a process to the dead pool."
|
|
(change-parent arg0 obj)
|
|
(none)
|
|
)
|
|
|
|
(defmethod new dead-pool-heap ((allocation symbol) (type-to-make type) (arg0 string) (arg1 int) (arg2 int))
|
|
"Allocate a new dead-pool-heap"
|
|
(let ((s2-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* 12 arg1))))))
|
|
(set! (-> s2-0 name) arg0)
|
|
(set! (-> s2-0 mask) (process-mask process-tree))
|
|
(set! (-> s2-0 allocated-length) arg1)
|
|
(set! (-> s2-0 parent) (the-as (pointer process-tree) #f))
|
|
(set! (-> s2-0 brother) (the-as (pointer process-tree) #f))
|
|
(set! (-> s2-0 child) (the-as (pointer process-tree) #f))
|
|
(set! (-> s2-0 self) s2-0)
|
|
(set! (-> s2-0 ppointer) (the-as (pointer process) (&-> s2-0 self)))
|
|
(init s2-0 allocation arg2)
|
|
s2-0
|
|
)
|
|
)
|
|
|
|
(defmethod init dead-pool-heap ((obj dead-pool-heap) (arg0 symbol) (arg1 int))
|
|
"Initialize the heap."
|
|
|
|
;; setup the records in a linked list, all referring to *null-process*.
|
|
(countdown (v1-0 (-> obj allocated-length))
|
|
(let ((a0-4 (-> obj process-list v1-0)))
|
|
(set! (-> a0-4 process) *null-process*)
|
|
(set! (-> a0-4 next) (-> obj process-list (+ v1-0 1)))
|
|
)
|
|
)
|
|
|
|
;; set the dead list to that list
|
|
(set! (-> obj dead-list next) (the-as dead-pool-heap-rec (-> obj process-list)))
|
|
|
|
;; clear alive list
|
|
(set! (-> obj alive-list process) #f)
|
|
|
|
;; terminate dead list.
|
|
(set! (-> obj process-list (+ (-> obj allocated-length) -1) next) #f)
|
|
(set! (-> obj alive-list prev) (-> obj alive-list))
|
|
(set! (-> obj alive-list next) #f)
|
|
(set! (-> obj alive-list process) #f)
|
|
(set! (-> obj first-gap) (-> obj alive-list))
|
|
(set! (-> obj first-shrink) #f)
|
|
|
|
(cond
|
|
((zero? arg1)
|
|
;; explicit support for a 0 size heap.
|
|
(set! (-> obj heap base) (the-as pointer 0))
|
|
(set! (-> obj heap current) (the-as pointer 0))
|
|
(set! (-> obj heap top) (the-as pointer 0))
|
|
(set! (-> obj heap top-base) (the-as pointer 0))
|
|
0
|
|
)
|
|
(else
|
|
;; otherwise allocate a heap.
|
|
(set! (-> obj heap base) (malloc arg0 arg1))
|
|
(set! (-> obj heap current) (-> obj heap base))
|
|
(set! (-> obj heap top) (&+ (-> obj heap base) arg1))
|
|
(set! (-> obj heap top-base) (-> obj heap top))
|
|
)
|
|
)
|
|
(none)
|
|
)
|
|
|
|
(defmethod gap-location dead-pool-heap ((obj dead-pool-heap) (arg0 dead-pool-heap-rec))
|
|
"Get the location of the first possible gap after the given record."
|
|
(the-as pointer
|
|
(if (-> arg0 process)
|
|
;; if we have a process, after that process
|
|
(+ (+ (-> arg0 process allocated-length) -4 (-> process size)) (the-as int (-> arg0 process)))
|
|
;; no process, just the start of the dead pool's big heap.
|
|
(-> obj heap base)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmethod gap-size dead-pool-heap ((obj dead-pool-heap) (arg0 dead-pool-heap-rec))
|
|
"Get the size of the gap after the given record (possibly 0)"
|
|
(cond
|
|
((-> arg0 process)
|
|
;; record has a proc
|
|
(let ((v1-3 (&+ (&+ (the-as pointer (-> arg0 process)) (-> process size)) (-> arg0 process allocated-length))))
|
|
(if (-> arg0 next)
|
|
;; and there's a next process, just get the gap in between those
|
|
(&- (the-as pointer (-> arg0 next process)) (the-as uint v1-3))
|
|
;; no next process, the gap is just the distance to the end of the dead pool's heap.
|
|
(&- (-> obj heap top) (the-as uint (&+ v1-3 4)))
|
|
)
|
|
)
|
|
)
|
|
((-> arg0 next)
|
|
;; record has no proc, go from start of dead pool heap to the next process.
|
|
(&- (the-as pointer (-> arg0 next process)) (the-as uint (&+ (-> obj heap base) 4)))
|
|
)
|
|
(else
|
|
;; no processes at all, the gap is the entire heap.
|
|
(&- (-> obj heap top) (the-as uint (-> obj heap base)))
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmethod find-gap dead-pool-heap ((obj dead-pool-heap) (arg0 dead-pool-heap-rec))
|
|
"Iterate through records, starting at the given one, and find the first one with a gap after it."
|
|
(while (and (-> arg0 next) (zero? (gap-size obj arg0)))
|
|
(set! arg0 (-> arg0 next))
|
|
)
|
|
arg0
|
|
)
|
|
|
|
(defmethod inspect dead-pool-heap ((obj dead-pool-heap))
|
|
"Inspect a dead-pool heap, printing proccesses and gaps."
|
|
(format #t "[~8x] ~A~%" obj (-> obj type))
|
|
(format #t "~Tname: ~A~%" (-> obj name))
|
|
(format #t "~1Tmask: #x~X : (process-mask " (-> obj mask))
|
|
(stream<-process-mask #t (-> obj mask))
|
|
(format #t ")~%")
|
|
(format #t "~Tparent: #x~X~%" (-> obj parent))
|
|
(format #t "~Tbrother: #x~X~%" (-> obj brother))
|
|
(format #t "~Tchild: #x~X~%" (-> obj child))
|
|
(format #t "~Tppointer: #x~X~%" (-> obj ppointer))
|
|
(format #t "~Tself: ~A~%" (-> obj self))
|
|
(format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
|
|
(format #t "~Theap: #<kheap @ #x~X>~%" (-> obj heap))
|
|
(format #t "~Tfirst-gap: #<dead-pool-heap-rec @ #x~X>~%" (-> obj first-gap))
|
|
(format #t "~Tfirst-shrink: #<dead-pool-heap-rec @ #x~X>~%" (-> obj first-shrink))
|
|
(format #t "~Talive-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj alive-list))
|
|
(format #t "~Tlast: #<dead-pool-heap-rec @ #x~X>~%" (-> obj alive-list prev))
|
|
(format #t "~Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj dead-list))
|
|
(let* ((s5-0 (&- (-> obj heap top) (the-as uint (-> obj heap base))))
|
|
(v1-3 (if (-> obj alive-list prev)
|
|
(gap-size obj (-> obj alive-list prev))
|
|
s5-0
|
|
)
|
|
)
|
|
)
|
|
(format #t "~Tprocess-list[0] @ #x~X ~D/~D bytes used~%" (-> obj process-list) (- s5-0 v1-3) s5-0)
|
|
)
|
|
(let ((s5-1 (-> obj alive-list))
|
|
(s4-0 0)
|
|
)
|
|
(while s5-1
|
|
(if (-> s5-1 process)
|
|
(format #t "~T [~3D] #<dead-pool-heap-rec @ #x~X> ~A~%" s4-0 s5-1 (-> s5-1 process))
|
|
)
|
|
(let ((s3-0 (gap-size obj s5-1)))
|
|
(if (nonzero? s3-0)
|
|
(format #t "~T gap: ~D bytes @ #x~X~%" s3-0 (gap-location obj s5-1))
|
|
)
|
|
)
|
|
(set! s5-1 (-> s5-1 next))
|
|
(+! s4-0 1)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
(defmethod asize-of dead-pool-heap ((obj dead-pool-heap))
|
|
"Get the size in memory of a dead-pool-heap."
|
|
(the-as int (+ (-> obj type size) (* 12 (-> obj allocated-length))))
|
|
)
|
|
|
|
(defmethod memory-used dead-pool-heap ((obj dead-pool-heap))
|
|
"Get the amount of used memory. Gaps in between processes are considered used."
|
|
(if (-> obj alive-list prev)
|
|
(- (memory-total obj) (gap-size obj (-> obj alive-list prev)))
|
|
0
|
|
)
|
|
)
|
|
|
|
(defmethod memory-total dead-pool-heap ((obj dead-pool-heap))
|
|
"Get the total size of the heap."
|
|
(&- (-> obj heap top) (the-as uint (-> obj heap base)))
|
|
)
|
|
|
|
(defmethod memory-free dead-pool-heap ((obj dead-pool-heap))
|
|
"Get the amount of free memory. Does not include gaps in between processes."
|
|
(let ((v1-0 (-> obj heap top)))
|
|
(if (-> obj alive-list prev)
|
|
(gap-size obj (-> obj alive-list prev))
|
|
(&- v1-0 (the-as uint (-> obj heap base)))
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmethod compact-time dead-pool-heap ((obj dead-pool-heap))
|
|
"Not working, likely was supposed to return how long the compaction took."
|
|
;; never set.
|
|
(-> obj compact-time)
|
|
)
|
|
|
|
(defmethod find-gap-by-size dead-pool-heap ((obj dead-pool-heap) (arg0 int))
|
|
"Find the first gap which is at least the given size."
|
|
(let ((gp-0 (-> obj first-gap)))
|
|
(while (and gp-0 (< (gap-size obj gp-0) arg0))
|
|
(set! gp-0 (-> gp-0 next))
|
|
)
|
|
gp-0
|
|
)
|
|
)
|
|
|
|
(defmethod get-process dead-pool-heap ((obj dead-pool-heap) (arg0 type) (arg1 int))
|
|
"Get a process!"
|
|
(let ((s4-0 (-> obj dead-list next))
|
|
(s3-0 (the-as process #f))
|
|
)
|
|
;; find a gap!
|
|
(let ((s1-0 (find-gap-by-size obj (the-as int (+ (-> process size) arg1)))))
|
|
(cond
|
|
((and s4-0 s1-0 (nonzero? (-> obj heap base))) ;; have record, gap, and heap, we are good!
|
|
;; get record
|
|
(set! (-> obj dead-list next) (-> s4-0 next))
|
|
(let ((v1-6 (-> s1-0 next)))
|
|
(set! (-> s1-0 next) s4-0)
|
|
(set! (-> s4-0 next) v1-6)
|
|
(if v1-6
|
|
(set! (-> v1-6 prev) s4-0)
|
|
)
|
|
)
|
|
(set! (-> s4-0 prev) s1-0)
|
|
(if (= s1-0 (-> obj alive-list prev))
|
|
(set! (-> obj alive-list prev) s4-0)
|
|
)
|
|
|
|
;; construct process in-place
|
|
(let ((a0-5 (gap-location obj s1-0)))
|
|
(set! s3-0 ((method-of-type process new) (the-as symbol a0-5) process "process" arg1))
|
|
)
|
|
|
|
;; link process to record
|
|
(set! (-> s4-0 process) s3-0)
|
|
(set! (-> s3-0 ppointer) (&-> s4-0 process))
|
|
|
|
;; update gap/shrinks
|
|
(if (= (-> obj first-gap) s1-0)
|
|
(set! (-> obj first-gap) (find-gap obj s4-0))
|
|
)
|
|
(if (or (not (-> obj first-shrink)) (< (the-as int s3-0) (the-as int (-> obj first-shrink process))))
|
|
(set! (-> obj first-shrink) s4-0)
|
|
)
|
|
|
|
;; setup process
|
|
(set! (-> s3-0 parent) (-> obj ppointer))
|
|
(set! (-> s3-0 pool) obj)
|
|
(set! (-> obj child) (&-> s4-0 process))
|
|
)
|
|
(else
|
|
(when (and *debug-segment* (!= obj *debug-dead-pool*))
|
|
(set! s3-0 (get-process *debug-dead-pool* arg0 arg1))
|
|
(if (and s3-0 *vis-boot*)
|
|
(format
|
|
0
|
|
"WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
|
|
arg0
|
|
s3-0
|
|
(-> obj name)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(if s3-0
|
|
(set! (-> s3-0 type) arg0)
|
|
(format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" arg0 s3-0 (-> obj name))
|
|
)
|
|
s3-0
|
|
)
|
|
)
|
|
|
|
;; decomp deviation
|
|
(defmethod return-process dead-pool-heap ((obj dead-pool-heap) (proc process))
|
|
"Return a process to a dead pool heap"
|
|
|
|
;; check we are returning to the correct pool
|
|
(unless (eq? obj (-> proc pool))
|
|
(format 0 "ERROR: process ~A does not belong to dead-pool-heap ~A.~%" proc obj)
|
|
)
|
|
|
|
;; reclaim us.
|
|
(change-parent proc obj)
|
|
|
|
;; we don't maintain a real tree for a dead-pool-heap, so undo any change to child
|
|
;; done by change-parent
|
|
(set! (-> obj child) #f)
|
|
|
|
;; we know our ppointer is really a rec for a dead-pool-heap process, so we can use
|
|
;; this trick to quickly find our rec.
|
|
(let ((rec (the dead-pool-heap-rec (-> proc ppointer))))
|
|
|
|
;; if we are at or below the first gap, update first gap.
|
|
(when (or (eq? (-> obj first-gap) rec)
|
|
(< (the int (gap-location obj rec)) (the int (gap-location obj (-> obj first-gap))))
|
|
)
|
|
(set! (-> obj first-gap) (-> rec prev))
|
|
)
|
|
|
|
|
|
;; update the first-shrink. We aren't smart about this and just move it backward.
|
|
(when (eq? (-> obj first-shrink) rec)
|
|
(set! (-> obj first-shrink) (-> rec prev))
|
|
(when (not (-> obj first-shrink process))
|
|
(set! (-> obj first-shrink) #f))
|
|
)
|
|
|
|
;; remove us from list
|
|
(set! (-> rec prev next) (-> rec next))
|
|
(cond
|
|
((-> rec next)
|
|
;; update links
|
|
(set! (-> rec next prev) (-> rec prev))
|
|
)
|
|
(else
|
|
;; we were last, update that.
|
|
(set! (-> obj last) (-> rec prev))
|
|
)
|
|
)
|
|
|
|
;; insert at the front of the dead list.
|
|
(set! (-> rec next) (-> obj dead-list next))
|
|
(set! (-> obj dead-list next) rec)
|
|
(set! (-> rec process) *null-process*)
|
|
|
|
(none)
|
|
)
|
|
)
|
|
|
|
(defmethod shrink-heap dead-pool-heap ((obj dead-pool-heap) (proc process))
|
|
"Shrink the heap of a process.
|
|
This resizes the process heap to be the exact size it is currently using."
|
|
(when proc
|
|
;; get our rec.
|
|
(let ((rec (the dead-pool-heap-rec (-> proc ppointer))))
|
|
;; check if it's ok to shrink
|
|
(unless (or (process-mask? (-> proc mask) heap-shrunk) ;; already shrunk
|
|
(and (not (-> proc next-state)) ;; uninitialized
|
|
(not (-> proc state))) ;; uninitialized
|
|
)
|
|
;; shrink!
|
|
(set! (-> proc allocated-length) (the int (&- (-> proc heap-cur) (-> proc stack))))
|
|
(set! (-> proc heap-top) (&-> (-> proc stack) (-> proc allocated-length)))
|
|
|
|
;; update first gap
|
|
(when (< (the int proc) (the int (gap-location obj (-> obj first-gap))))
|
|
(set! (-> obj first-gap) (find-gap obj rec))
|
|
)
|
|
|
|
;; mark us as shrunk
|
|
(process-mask-set! (-> proc mask) heap-shrunk)
|
|
)
|
|
|
|
;; update first shrink
|
|
(when (eq? (-> obj first-shrink) rec)
|
|
(set! (-> obj first-shrink) (-> rec next))
|
|
)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
;; decomp deviation
|
|
|
|
(defmethod compact dead-pool-heap ((obj dead-pool-heap) (arg0 int))
|
|
"Relocate processes to remove gaps and increase free memory."
|
|
|
|
;; skip if we're an empty dead-pool-heap
|
|
(if (zero? (-> obj heap base))
|
|
(return 0)
|
|
)
|
|
|
|
;; if we're almost out of memory, increase the compaction amount.
|
|
(let* ((s4-0 (memory-free obj))
|
|
(v1-5 (memory-total obj))
|
|
(f0-2 (/ (the float s4-0) (the float v1-5)))
|
|
)
|
|
(cond
|
|
((< f0-2 0.1)
|
|
(set! arg0 1000)
|
|
;; really low, complain.
|
|
(if (and *debug-segment* (-> *kernel-context* low-memory-message))
|
|
(format *stdcon* "~3LLow Actor Memory~%~0L")
|
|
)
|
|
)
|
|
((< f0-2 0.2)
|
|
(set! arg0 (* arg0 4))
|
|
)
|
|
((< f0-2 0.3)
|
|
(set! arg0 (* arg0 2))
|
|
)
|
|
)
|
|
)
|
|
(set! (-> obj compact-count-targ) (the-as uint arg0))
|
|
(set! (-> obj compact-count) (the-as uint 0))
|
|
|
|
;; loop over compactions.
|
|
(while (nonzero? arg0)
|
|
(+! arg0 -1)
|
|
|
|
;; try to get something to shrink
|
|
(let ((v1-19 (-> obj first-shrink)))
|
|
(when (not v1-19)
|
|
(set! v1-19 (-> obj alive-list next))
|
|
(set! (-> obj first-shrink) v1-19)
|
|
)
|
|
(if v1-19
|
|
;; got something, shrink it.
|
|
(shrink-heap obj (-> v1-19 process))
|
|
)
|
|
)
|
|
|
|
;; move to fill the gap.
|
|
(let ((s4-1 (-> obj first-gap)))
|
|
(when (-> s4-1 next)
|
|
(let ((s3-0 (-> s4-1 next process))
|
|
(s2-0 (gap-size obj s4-1))
|
|
)
|
|
(when (nonzero? s2-0)
|
|
(when (< s2-0 0)
|
|
;; bug, negative size.
|
|
(break!)
|
|
)
|
|
;; shrink before moving.
|
|
(shrink-heap obj s3-0)
|
|
;; do the relocation! the relocate method of process does the actual memcpy.
|
|
(relocate s3-0 (- s2-0))
|
|
;; update gaps
|
|
(set! (-> obj first-gap) (find-gap obj s4-1))
|
|
(+! (-> obj compact-count) 1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
0
|
|
(none)
|
|
)
|
|
|
|
(defmethod churn dead-pool-heap ((obj dead-pool-heap) (arg0 int))
|
|
"Relocate processes to debug process relocation."
|
|
(while (nonzero? arg0)
|
|
(+! arg0 -1)
|
|
(let ((s4-0 (-> obj alive-list next)))
|
|
(when s4-0
|
|
(if (or (= (-> obj first-gap) s4-0)
|
|
(< (the-as int (gap-location obj s4-0)) (the-as int (gap-location obj (-> obj first-gap))))
|
|
)
|
|
(set! (-> obj first-gap) (-> s4-0 prev))
|
|
)
|
|
(when (= (-> obj first-shrink) s4-0)
|
|
(set! (-> obj first-shrink) (-> s4-0 prev))
|
|
(if (not (-> obj first-shrink process))
|
|
(set! (-> obj first-shrink) #f)
|
|
)
|
|
)
|
|
(set! (-> s4-0 prev next) (-> s4-0 next))
|
|
(if (-> s4-0 next)
|
|
(set! (-> s4-0 next prev) (-> s4-0 prev))
|
|
(set! (-> obj alive-list prev) (-> s4-0 prev))
|
|
)
|
|
(let ((a1-3 (-> obj alive-list prev)))
|
|
(let ((v1-19 (-> a1-3 next)))
|
|
(set! (-> a1-3 next) s4-0)
|
|
(set! (-> s4-0 next) v1-19)
|
|
(if v1-19
|
|
(set! (-> v1-19 prev) s4-0)
|
|
)
|
|
)
|
|
(set! (-> s4-0 prev) a1-3)
|
|
(set! (-> obj alive-list prev) s4-0)
|
|
(set! (-> s4-0 process)
|
|
(relocate (-> s4-0 process) (&- (gap-location obj a1-3) (the-as uint (&-> (-> s4-0 process) type))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
0
|
|
(none)
|
|
)
|
|
|
|
(defun method-state ((arg0 type) (arg1 basic))
|
|
"Get a state by name from the method table of a type."
|
|
(dotimes (v1-0 (the-as int (-> arg0 allocated-length)))
|
|
(let ((a2-2 (the-as basic (-> arg0 method-table v1-0))))
|
|
(if (and (nonzero? (the-as function a2-2))
|
|
(= (-> (the-as function a2-2) type) state)
|
|
(= (-> (the-as state a2-2) name) arg1)
|
|
)
|
|
(return (the-as state a2-2))
|
|
)
|
|
)
|
|
)
|
|
(the-as state #f)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Process Searching and Iterating
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; goal lambdas don't "capture" variables successfully, so this is a workaround.
|
|
(define *global-search-name* (the-as basic #f))
|
|
(define *global-search-count* 0)
|
|
|
|
(defun process-by-name ((arg0 string) (arg1 process-tree))
|
|
"Get a process by name."
|
|
(set! *global-search-name* arg0)
|
|
(the-as process (search-process-tree
|
|
arg1
|
|
(lambda ((arg0 process)) (string= (-> arg0 name) (the-as string *global-search-name*)))
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun process-not-name ((arg0 string) (arg1 process-tree))
|
|
"Get a process that doesn't have the given name."
|
|
(set! *global-search-name* (the-as basic arg0))
|
|
(the-as
|
|
process
|
|
(search-process-tree
|
|
arg1
|
|
(lambda ((arg0 process)) (not (string= (-> arg0 name) (the-as string *global-search-name*))))
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun process-count ((arg0 process-tree))
|
|
"Count the number of processes in the given tree."
|
|
(set! *global-search-count* 0)
|
|
(iterate-process-tree
|
|
arg0
|
|
(lambda ((arg0 process)) (set! *global-search-count* (+ *global-search-count* 1)) #t)
|
|
*null-kernel-context*
|
|
)
|
|
*global-search-count*
|
|
)
|
|
|
|
(defun kill-by-name ((arg0 string) (arg1 process-tree))
|
|
"Kill all processes with the given name."
|
|
(local-vars (a0-1 process))
|
|
(while (begin (set! a0-1 (process-by-name arg0 arg1)) a0-1)
|
|
(deactivate a0-1)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun kill-by-type ((arg0 type) (arg1 process-tree))
|
|
"Kill all processes with the given type."
|
|
(local-vars (a0-1 process-tree))
|
|
(set! *global-search-name* arg0)
|
|
(while (begin
|
|
(set! a0-1 (search-process-tree arg1 (lambda ((arg0 process)) (= (-> arg0 type) *global-search-name*))))
|
|
a0-1
|
|
)
|
|
(deactivate a0-1)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun kill-not-name ((arg0 string) (arg1 process-tree))
|
|
"Kill all processes, except for ones named this."
|
|
(local-vars (a0-1 process))
|
|
(while (begin (set! a0-1 (process-not-name arg0 arg1)) a0-1)
|
|
(deactivate a0-1)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun kill-not-type ((arg0 type) (arg1 process-tree))
|
|
"Kill all processes not of the given type."
|
|
(local-vars (a0-1 process-tree))
|
|
(set! *global-search-name* arg0)
|
|
(while (begin
|
|
(set! a0-1 (search-process-tree arg1 (lambda ((arg0 process)) (!= (-> arg0 type) *global-search-name*))))
|
|
a0-1
|
|
)
|
|
(deactivate a0-1)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defmethod run-logic? process ((obj process))
|
|
"Should this process be run by the kernel?"
|
|
#t
|
|
)
|
|
|
|
(defun iterate-process-tree ((arg0 process-tree) (arg1 (function object object)) (arg2 kernel-context))
|
|
"Iterate over the process tree, calling the function on each process."
|
|
(let ((s4-0 (or (logtest? (-> arg0 mask) (process-mask process-tree)) (arg1 arg0))))
|
|
(cond
|
|
((= s4-0 'dead)
|
|
;; the function returned dead, don't look at children.
|
|
)
|
|
(else
|
|
;; iterate over children too.
|
|
(let ((v1-4 (-> arg0 child)))
|
|
(while v1-4
|
|
(let ((s3-1 (-> v1-4 0 brother)))
|
|
(iterate-process-tree (-> v1-4 0) arg1 arg2)
|
|
(set! v1-4 s3-1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
s4-0
|
|
)
|
|
)
|
|
|
|
(defun execute-process-tree ((arg0 process-tree) (arg1 (function object object)) (arg2 kernel-context))
|
|
"Iterate over the process tree, running only if the mask doesn't prevent it.
|
|
Update the mask of the process-tree to have kernel-run if and only if we run at least one process."
|
|
|
|
;; start with this cleared
|
|
(logclear! (-> arg0 mask) (process-mask kernel-run))
|
|
|
|
;; prevent run if:
|
|
;; - we are a process-tree
|
|
;; - we are prevent-from-run
|
|
;; - we don't return #t for run-logic?
|
|
(let ((s3-0 (or (logtest? (-> arg0 mask) (process-mask process-tree))
|
|
;; prevent if not both (clear to run and run-logic? = #t)
|
|
(not (and (zero? (logand (-> arg2 prevent-from-run) (-> arg0 mask))) (run-logic? arg0)))
|
|
(begin (logior! (-> arg0 mask) (process-mask kernel-run)) (arg1 arg0))
|
|
)
|
|
)
|
|
)
|
|
(cond
|
|
((= s3-0 'dead)
|
|
;; don't check children if dead.
|
|
)
|
|
(else
|
|
(let ((v1-12 (-> arg0 child)))
|
|
(while v1-12
|
|
(let ((s4-1 (-> v1-12 0 brother)))
|
|
(execute-process-tree (-> v1-12 0) arg1 arg2)
|
|
(set! v1-12 s4-1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
s3-0
|
|
)
|
|
)
|
|
|
|
(defun search-process-tree ((arg0 process-tree) (arg1 (function process-tree object)))
|
|
"Iterate process tree, returning the process that returns #t first."
|
|
(when (zero? (logand (-> arg0 mask) (process-mask process-tree)))
|
|
(if (arg1 arg0)
|
|
(return arg0)
|
|
)
|
|
)
|
|
(let ((v1-5 (-> arg0 child)))
|
|
(while v1-5
|
|
(let ((s5-1 (-> v1-5 0 brother)))
|
|
(let ((v1-6 (search-process-tree (-> v1-5 0) arg1)))
|
|
(if v1-6
|
|
(return v1-6)
|
|
)
|
|
)
|
|
(set! v1-5 s5-1)
|
|
)
|
|
)
|
|
)
|
|
(the-as process-tree #f)
|
|
)
|
|
|
|
;; decomp deviation
|
|
(defun kernel-dispatcher ()
|
|
"Main entry point to GOAL from C++."
|
|
|
|
;; added
|
|
;; outside of all profiler events, set a ROOT event
|
|
(profiler-instant-event "ROOT")
|
|
|
|
;; run any listener functions
|
|
(when *listener-function*
|
|
(set! *enable-method-set* (+ *enable-method-set* 1))
|
|
(let ((t1-0 (reset-and-call (-> *listener-process* main-thread) *listener-function*)))
|
|
(if *use-old-listener-print*
|
|
(format #t "~D~%" t1-0 t1-0 t1-0)
|
|
(format #t "~D #x~X ~F ~A~%" t1-0 t1-0 t1-0 t1-0)
|
|
)
|
|
)
|
|
(set! *listener-function* #f)
|
|
(set! *enable-method-set* (+ *enable-method-set* -1))
|
|
)
|
|
|
|
;; for each active proces...
|
|
(execute-process-tree
|
|
*active-pool*
|
|
(lambda ((arg0 process))
|
|
;; (+! (-> *canary-1*) 1)
|
|
;; (+! (-> *canary-2*) 1)
|
|
;; (+! (-> *canary-3*) 1)
|
|
(let ((s5-0 *kernel-context*))
|
|
(case (-> arg0 status)
|
|
(('waiting-to-run 'suspended)
|
|
;; we'll run this process
|
|
(profiler-start-event (-> arg0 name))
|
|
(set! (-> s5-0 current-process) arg0)
|
|
(cond
|
|
((logtest? (-> arg0 mask) (process-mask pause))
|
|
;; we can be paused, write messages/debug-draw to buffers that aren't cleared
|
|
;; when the game is paused.
|
|
(set! *stdcon* *stdcon1*)
|
|
(set! *debug-draw-pauseable* #t)
|
|
)
|
|
(else
|
|
;; not pausable, write to buffers that clear each frame.
|
|
(set! *stdcon* *stdcon0*)
|
|
(set! *debug-draw-pauseable* #f)
|
|
)
|
|
)
|
|
|
|
;; run the trans function.
|
|
;; (format 0 "Trans | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
|
|
(when (-> arg0 trans-hook)
|
|
(let ((s4-0 (new 'process 'cpu-thread arg0 'trans 256 (-> arg0 main-thread stack-top))))
|
|
(with-pc-profiler "trans"
|
|
(reset-and-call s4-0 (-> arg0 trans-hook))
|
|
)
|
|
(delete s4-0)
|
|
)
|
|
(when (= (-> arg0 status) 'dead) ;; handle deactivates in trans
|
|
(set! (-> s5-0 current-process) #f)
|
|
(profiler-end-event)
|
|
(return 'dead)
|
|
)
|
|
)
|
|
|
|
;; run the main thread!
|
|
;; (format 0 "Code | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
|
|
(if (logtest? (-> arg0 mask) (process-mask sleep-code))
|
|
(set! (-> arg0 status) 'suspended)
|
|
(with-pc-profiler "code"
|
|
((-> arg0 main-thread resume-hook) (-> arg0 main-thread))
|
|
)
|
|
)
|
|
;; (format 0 "Finished Code | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
|
|
|
|
|
|
(cond
|
|
((= (-> arg0 status) 'dead) ;; handle death in main thread.
|
|
(set! (-> s5-0 current-process) #f)
|
|
(profiler-end-event)
|
|
'dead
|
|
)
|
|
(else
|
|
;; run post.
|
|
;; NOTE: post always runs on the dram stack, so you can use ja-post and use the scratchpad for anims.
|
|
;; (format 0 "Post | Proc '~A' | C1: ~X C2: ~X C3: ~X~%" (-> arg0 name) (-> *canary-1*) (-> *canary-2*) (-> *canary-3*))
|
|
(when (-> arg0 post-hook)
|
|
(let ((s4-1 (new 'process 'cpu-thread arg0 'post 256 *kernel-dram-stack*)))
|
|
(with-pc-profiler "post"
|
|
(reset-and-call s4-1 (-> arg0 post-hook))
|
|
)
|
|
(delete s4-1)
|
|
)
|
|
(when (= (-> arg0 status) 'dead) ;; handle death in post
|
|
(set! (-> s5-0 current-process) #f)
|
|
(profiler-end-event)
|
|
(return 'dead)
|
|
)
|
|
(set! (-> arg0 status) 'suspended)
|
|
)
|
|
;; done with process.
|
|
(set! (-> s5-0 current-process) #f)
|
|
(profiler-end-event)
|
|
#f
|
|
)
|
|
)
|
|
)
|
|
(('dead)
|
|
'dead
|
|
)
|
|
)
|
|
)
|
|
)
|
|
*kernel-context*
|
|
)
|
|
)
|
|
|
|
#|
|
|
(defun kernel-dispatcher ()
|
|
"Run the kernel!
|
|
This is the entry point from C++ to GOAL."
|
|
|
|
;; outside of all profiler events, set a ROOT event
|
|
(profiler-instant-event "ROOT")
|
|
|
|
;; execute the listener function, if we got one.
|
|
(when *listener-function*
|
|
(+! *enable-method-set* 1) ;; allow out-of-order method definitions (slower)
|
|
;; (let ((result (reset-and-call (-> *listener-process* main-thread) *listener-function*))) ;; run function!
|
|
(let ((result (*listener-function*)))
|
|
;; print result.
|
|
(if *use-old-listener-print*
|
|
(format #t "~D~%" result result result)
|
|
(format #t "~D #x~X ~F ~A~%" result result result result)
|
|
)
|
|
)
|
|
;; clear pending function
|
|
(set! *listener-function* #f)
|
|
(+! *enable-method-set* -1)
|
|
)
|
|
)
|
|
|
|
|#
|
|
;; decomp deviation
|
|
|
|
(defun sync-dispatcher ()
|
|
"Run just the listener function. Used for SQL query stuff."
|
|
(let ((t9-0 *listener-function*))
|
|
(the-as object (when t9-0
|
|
(set! *listener-function* #f)
|
|
(t9-0)
|
|
#f
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun inspect-process-tree ((arg0 process-tree) (arg1 int) (arg2 int) (arg3 symbol))
|
|
"Print out a process tree diagram."
|
|
(print-tree-bitmask arg2 arg1)
|
|
(cond
|
|
(arg3
|
|
(format #t "__________________~%")
|
|
(format
|
|
#t
|
|
"~S~A~%"
|
|
(if (zero? arg1)
|
|
""
|
|
"+---"
|
|
)
|
|
arg0
|
|
)
|
|
(let ((s2-0 *print-column*))
|
|
(set! *print-column* (the binteger (* arg1 4)))
|
|
(inspect arg0)
|
|
(set! *print-column* s2-0)
|
|
)
|
|
)
|
|
(else
|
|
(format
|
|
#t
|
|
"~S~A~%"
|
|
(if (zero? arg1)
|
|
""
|
|
"+---"
|
|
)
|
|
arg0
|
|
)
|
|
)
|
|
)
|
|
(let ((s2-1 (-> arg0 child)))
|
|
(while s2-1
|
|
(inspect-process-tree
|
|
(-> s2-1 0)
|
|
(+ arg1 1)
|
|
(if (not (-> s2-1 0 brother))
|
|
arg2
|
|
(logior arg2 (ash 1 (+ arg1 1)))
|
|
)
|
|
arg3
|
|
)
|
|
(set! s2-1 (-> s2-1 0 brother))
|
|
)
|
|
)
|
|
arg0
|
|
)
|
|
|
|
(defmacro set-u128-as-u64! (dst src)
|
|
`(set! (-> (the (pointer uint64) (& ,dst)))
|
|
,src
|
|
)
|
|
)
|
|
|
|
(defmacro set-u64-from-u128! (dst src)
|
|
`(set! ,dst (-> (the (pointer uint64) (& ,src))))
|
|
)
|
|
|
|
(defmacro the-super-u64-fucntion (func)
|
|
`(the-as (function uint uint uint uint uint uint object) ,func)
|
|
)
|
|
|
|
;; decomp deviation
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Stack Frame Stuff
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; The GOAL kernel supports dynamic throw and catch.
|
|
;; The catch frames are managed per process (you can't throw to a frame outside your process)
|
|
;; But otherwise it is fully dynamic.
|
|
|
|
(defmethod new catch-frame ((allocation symbol) (type-to-make type) (name symbol) (func function) (param-block (pointer uint64)))
|
|
"Run func in a catch frame with the given 8 parameters.
|
|
The return value is the result of the function.
|
|
The allocation must be an address.
|
|
Unlike the original, this only works on the first six parameters, but I think this doesn't matter."
|
|
(declare (asm-func object)
|
|
(allow-saved-regs) ;; very dangerous!
|
|
)
|
|
|
|
(rlet ((pp :reg r13 :type process)
|
|
(temp :reg rax :type uint)
|
|
(off :reg r15 :type uint)
|
|
(sp :reg rsp :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type (pointer uint64))
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
|
|
(xmm8 :reg xmm8 :class fpr)
|
|
(xmm9 :reg xmm9 :class fpr)
|
|
(xmm10 :reg xmm10 :class fpr)
|
|
(xmm11 :reg xmm11 :class fpr)
|
|
(xmm12 :reg xmm12 :class fpr)
|
|
(xmm13 :reg xmm13 :class fpr)
|
|
(xmm14 :reg xmm14 :class fpr)
|
|
(xmm15 :reg xmm15 :class fpr)
|
|
)
|
|
|
|
;; we treat the allocation as an address.
|
|
(let ((obj (the catch-frame (&+ (the pointer allocation) *gtype-basic-offset*))))
|
|
;; setup catch frame
|
|
(set! (-> obj type) type-to-make)
|
|
(set! (-> obj name) name)
|
|
;; get the return address (the compiler won't touch the stack because we're an asm-func)
|
|
(.pop temp)
|
|
(.push temp)
|
|
;; make it a GOAL address so it fits in 32 bits
|
|
(.sub temp off)
|
|
;; store it
|
|
(set! (-> obj ra) (the int temp))
|
|
|
|
;; todo, do we need a stack offset here?
|
|
;; remember the stack pointer
|
|
(set! temp sp)
|
|
(.sub temp off)
|
|
(set! (-> obj sp) (the int temp))
|
|
|
|
;; back up registers we care about
|
|
(.mov :color #f temp s0)
|
|
(set-u128-as-u64! (-> obj rreg 0) temp)
|
|
(.mov :color #f temp s1)
|
|
(set-u128-as-u64! (-> obj rreg 1) temp)
|
|
(.mov :color #f temp s2)
|
|
(set-u128-as-u64! (-> obj rreg 2) temp)
|
|
(.mov :color #f temp s3)
|
|
(set-u128-as-u64! (-> obj rreg 3) temp)
|
|
(.mov :color #f temp s4)
|
|
(set-u128-as-u64! (-> obj rreg 4) temp)
|
|
|
|
(.mov :color #f temp xmm8)
|
|
(set! (-> obj freg 0) (the-as float temp))
|
|
(.mov :color #f temp xmm9)
|
|
(set! (-> obj freg 1) (the-as float temp))
|
|
(.mov :color #f temp xmm10)
|
|
(set! (-> obj freg 2) (the-as float temp))
|
|
(.mov :color #f temp xmm11)
|
|
(set! (-> obj freg 3) (the-as float temp))
|
|
(.mov :color #f temp xmm12)
|
|
(set! (-> obj freg 4) (the-as float temp))
|
|
(.mov :color #f temp xmm13)
|
|
(set! (-> obj freg 5) (the-as float temp))
|
|
(.mov :color #f temp xmm14)
|
|
(set! (-> obj freg 6) (the-as float temp))
|
|
(.mov :color #f temp xmm15)
|
|
(set! (-> obj freg 7) (the-as float temp))
|
|
|
|
;; push this stack frame
|
|
(set! (-> obj next) (-> pp stack-frame-top))
|
|
(set! (-> pp stack-frame-top) obj)
|
|
|
|
;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
|
|
(.push :color #f s3)
|
|
(.push :color #f s2)
|
|
(.push :color #f s2)
|
|
(set! s3 (the uint func))
|
|
(set! s2 param-block)
|
|
|
|
;; todo - are we aligned correctly here?
|
|
(let ((ret ((the-super-u64-fucntion s3)
|
|
(-> s2 0)
|
|
(-> s2 1)
|
|
(-> s2 2)
|
|
(-> s2 3)
|
|
(-> s2 4)
|
|
(-> s2 5)
|
|
))
|
|
)
|
|
(.pop :color #f s2)
|
|
(.pop :color #f s2)
|
|
(.pop :color #f s3)
|
|
(set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
|
|
(.ret)
|
|
(the object ret)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun throw-dispatch ((obj catch-frame) value)
|
|
"Throw the given value to the catch frame.
|
|
Only can throw a 64-bit value. The original could throw 128 bits."
|
|
(declare (asm-func none))
|
|
|
|
(rlet ((pp :reg r13 :type process)
|
|
(temp :reg rax :type uint)
|
|
(off :reg r15 :type uint)
|
|
(sp :reg rsp :type uint)
|
|
(s0 :reg rbx :type uint)
|
|
(s1 :reg rbp :type uint)
|
|
(s2 :reg r10 :type (pointer uint64))
|
|
(s3 :reg r11 :type uint)
|
|
(s4 :reg r12 :type uint)
|
|
|
|
(temp-float :reg xmm0 :class fpr)
|
|
(xmm8 :reg xmm8 :class fpr)
|
|
(xmm9 :reg xmm9 :class fpr)
|
|
(xmm10 :reg xmm10 :class fpr)
|
|
(xmm11 :reg xmm11 :class fpr)
|
|
(xmm12 :reg xmm12 :class fpr)
|
|
(xmm13 :reg xmm13 :class fpr)
|
|
(xmm14 :reg xmm14 :class fpr)
|
|
(xmm15 :reg xmm15 :class fpr)
|
|
)
|
|
|
|
;; pop everything we threw past
|
|
(set! (-> pp stack-frame-top) (-> obj next))
|
|
|
|
;; restore regs we care about.
|
|
(set-u64-from-u128! temp (-> obj rreg 0))
|
|
(.mov :color #f s0 temp)
|
|
(set-u64-from-u128! temp (-> obj rreg 1))
|
|
(.mov :color #f s1 temp)
|
|
(set-u64-from-u128! temp (-> obj rreg 2))
|
|
(.mov :color #f s2 temp)
|
|
(set-u64-from-u128! temp (-> obj rreg 3))
|
|
(.mov :color #f s3 temp)
|
|
(set-u64-from-u128! temp (-> obj rreg 4))
|
|
(.mov :color #f s4 temp)
|
|
|
|
(set! temp-float (-> obj freg 0))
|
|
(.mov :color #f xmm8 temp-float)
|
|
(set! temp-float (-> obj freg 1))
|
|
(.mov :color #f xmm9 temp-float)
|
|
(set! temp-float (-> obj freg 2))
|
|
(.mov :color #f xmm10 temp-float)
|
|
(set! temp-float (-> obj freg 3))
|
|
(.mov :color #f xmm11 temp-float)
|
|
(set! temp-float (-> obj freg 4))
|
|
(.mov :color #f xmm12 temp-float)
|
|
(set! temp-float (-> obj freg 5))
|
|
(.mov :color #f xmm13 temp-float)
|
|
(set! temp-float (-> obj freg 6))
|
|
(.mov :color #f xmm14 temp-float)
|
|
(set! temp-float (-> obj freg 7))
|
|
(.mov :color #f xmm15 temp-float)
|
|
|
|
;; set stack pointer
|
|
(set! sp (the uint (-> obj sp)))
|
|
(.add sp off)
|
|
|
|
;; overwrite our return address
|
|
(.pop temp)
|
|
(set! temp (the uint (-> obj ra)))
|
|
(.add temp off)
|
|
(.push temp)
|
|
|
|
;; load the return register
|
|
(.mov temp value)
|
|
(.ret)
|
|
)
|
|
)
|
|
|
|
(defun throw ((name symbol) value)
|
|
"Dynamic throw."
|
|
(rlet ((pp :reg r13 :type process))
|
|
(let ((cur (-> pp stack-frame-top)))
|
|
(while cur
|
|
(when (and (eq? (-> cur name) name) (eq? (-> cur type) catch-frame))
|
|
;; match!
|
|
|
|
(throw-dispatch (the catch-frame cur) value)
|
|
)
|
|
|
|
(if (eq? (-> cur type) protect-frame)
|
|
;; call the cleanup function
|
|
((-> (the protect-frame cur) exit))
|
|
)
|
|
(set! cur (-> cur next))
|
|
)
|
|
)
|
|
)
|
|
(format 0 "ERROR: throw could not find tag ~A~%" name)
|
|
(break)
|
|
)
|
|
;; decomp deviation
|
|
|
|
(defmethod new protect-frame ((allocation symbol) (type-to-make type) (arg0 (function none)))
|
|
"Create a new protect frame, must be on the stack."
|
|
(with-pp
|
|
(let ((v0-0 (the-as protect-frame (+ (the-as int allocation) 4))))
|
|
(set! (-> v0-0 type) type-to-make)
|
|
(set! (-> v0-0 name) 'protect-frame)
|
|
(set! (-> v0-0 exit) arg0)
|
|
(set! (-> v0-0 next) (-> pp stack-frame-top))
|
|
(set! (-> pp stack-frame-top) v0-0)
|
|
v0-0
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun previous-brother ((arg0 process-tree))
|
|
(let ((v1-0 (-> arg0 parent)))
|
|
(when v1-0
|
|
(let ((v1-2 (-> v1-0 0 child)))
|
|
(if (= v1-2 arg0)
|
|
(return (the-as object #f))
|
|
)
|
|
(while v1-2
|
|
(if (= (-> v1-2 0 brother) arg0)
|
|
(return (the-as object v1-2))
|
|
)
|
|
(set! v1-2 (-> v1-2 0 brother))
|
|
)
|
|
)
|
|
(the-as (pointer process-tree) #f)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun change-parent ((arg0 process-tree) (arg1 process-tree))
|
|
(let ((a2-0 (-> arg0 parent)))
|
|
(when a2-0
|
|
(let ((v1-2 (-> a2-0 0 child)))
|
|
(cond
|
|
((= (ppointer->process v1-2) arg0)
|
|
(set! (-> a2-0 0 child) (-> arg0 brother))
|
|
)
|
|
(else
|
|
(while (!= (ppointer->process (-> v1-2 0 brother)) arg0)
|
|
(nop!)
|
|
(nop!)
|
|
(nop!)
|
|
(set! v1-2 (-> v1-2 0 brother))
|
|
)
|
|
(set! (-> v1-2 0 brother) (-> arg0 brother))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> arg0 parent) (-> arg1 ppointer))
|
|
(set! (-> arg0 brother) (-> arg1 child))
|
|
(set! (-> arg1 child) (-> arg0 ppointer))
|
|
arg0
|
|
)
|
|
|
|
(defun change-brother ((arg0 process-tree) (arg1 process-tree))
|
|
(when (and arg0 (!= (-> arg0 brother) arg1) (!= arg0 arg1))
|
|
(let ((a2-1 (-> arg0 parent)))
|
|
(when a2-1
|
|
(let ((t0-0 (-> a2-1 0 child))
|
|
(a3-1 (the-as (pointer process-tree) #f))
|
|
(v1-4 (the-as (pointer process-tree) #f))
|
|
)
|
|
(if (= (ppointer->process t0-0) arg0)
|
|
(set! a3-1 a2-1)
|
|
)
|
|
(if (= (ppointer->process t0-0) arg1)
|
|
(set! v1-4 a2-1)
|
|
)
|
|
(while (and (-> t0-0 0 brother) (or (not a3-1) (not v1-4)))
|
|
(if (= (-> (ppointer->process t0-0) brother) arg1)
|
|
(set! v1-4 t0-0)
|
|
)
|
|
(if (= (-> (ppointer->process t0-0) brother) arg0)
|
|
(set! a3-1 t0-0)
|
|
)
|
|
(set! t0-0 (-> t0-0 0 brother))
|
|
)
|
|
(cond
|
|
((or (not a3-1) (not v1-4))
|
|
(return 0)
|
|
)
|
|
((= a3-1 a2-1)
|
|
(set! (-> a3-1 5) (the-as process-tree (-> arg0 brother)))
|
|
)
|
|
(else
|
|
(set! (-> a3-1 4) (the-as process-tree (-> arg0 brother)))
|
|
)
|
|
)
|
|
(cond
|
|
((= v1-4 a2-1)
|
|
(set! (-> arg0 brother) (the-as (pointer process-tree) (-> v1-4 5)))
|
|
(set! (-> v1-4 5) (the-as process-tree (-> arg0 ppointer)))
|
|
)
|
|
(else
|
|
(set! (-> arg0 brother) (the-as (pointer process-tree) (-> v1-4 4)))
|
|
(set! (-> v1-4 4) (the-as process-tree (-> arg0 ppointer)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
arg0
|
|
)
|
|
|
|
(defun change-to-last-brother ((arg0 process-tree))
|
|
(when (and (-> arg0 brother) (-> arg0 parent))
|
|
(let* ((a1-0 (-> arg0 parent))
|
|
(v1-4 (-> a1-0 0 child))
|
|
)
|
|
(cond
|
|
((= (-> v1-4 0) arg0)
|
|
(set! (-> a1-0 0 child) (-> arg0 brother))
|
|
)
|
|
(else
|
|
(while (!= (-> v1-4 0 brother 0) arg0)
|
|
(nop!)
|
|
(nop!)
|
|
(nop!)
|
|
(nop!)
|
|
(set! v1-4 (-> v1-4 0 brother))
|
|
)
|
|
(set! (-> v1-4 0 brother) (-> arg0 brother))
|
|
)
|
|
)
|
|
(while (-> v1-4 0 brother)
|
|
(nop!)
|
|
(nop!)
|
|
(nop!)
|
|
(nop!)
|
|
(set! v1-4 (-> v1-4 0 brother))
|
|
)
|
|
(set! (-> v1-4 0 brother) (-> arg0 ppointer))
|
|
)
|
|
(set! (-> arg0 brother) (the-as (pointer process-tree) #f))
|
|
)
|
|
arg0
|
|
)
|
|
|
|
;; decomp deviation
|
|
(defmethod activate process ((obj process) (arg0 process-tree) (arg1 basic) (arg2 pointer))
|
|
"Start a process!"
|
|
;; if we got the scratchpad stack, move to the fake scratchpad.
|
|
(#when PC_PORT
|
|
(when (= arg2 *scratch-memory-top*)
|
|
(set! arg2 (&+ *fake-scratchpad-stack* (* 32 1024)))
|
|
)
|
|
)
|
|
(set! (-> obj mask) (logclear (-> arg0 mask) (process-mask sleep sleep-code process-tree heap-shrunk)))
|
|
|
|
;; inherit clock
|
|
(set! (-> obj clock) (-> arg0 clock))
|
|
(set! (-> obj status) 'ready)
|
|
;; get unique pid
|
|
(let ((v1-5 (-> *kernel-context* next-pid)))
|
|
(set! (-> obj pid) v1-5)
|
|
(set! (-> *kernel-context* next-pid) (+ v1-5 1))
|
|
)
|
|
(set! (-> obj top-thread) #f)
|
|
(set! (-> obj main-thread) #f)
|
|
(set! (-> obj name) (the-as string arg1))
|
|
;; adjust heap to leave a gap for child of process fields
|
|
(let ((v1-10 (&-> obj stack (-> obj type heap-base))))
|
|
(set! (-> obj heap-cur) v1-10)
|
|
(set! (-> obj heap-base) v1-10)
|
|
)
|
|
(set! (-> obj stack-frame-top) #f)
|
|
;; clear the heap
|
|
(mem-set32! (-> obj stack) (the-as int (shr (-> obj type heap-base) 2)) 0)
|
|
(set! (-> obj trans-hook) #f)
|
|
(set! (-> obj post-hook) #f)
|
|
(set! (-> obj event-hook) #f)
|
|
(set! (-> obj state) #f)
|
|
(set! (-> obj next-state) #f)
|
|
(cond
|
|
((logtest? (-> arg0 mask) (process-mask process-tree))
|
|
;; spawned with a tree as the parent, which doesn't have a level/entity. So pick defaults
|
|
(set! (-> obj entity) #f)
|
|
(set! (-> obj level) *default-level*)
|
|
)
|
|
(else
|
|
;; parent is another process, inherit level/entity.
|
|
(set! (-> obj entity) (-> (the-as process arg0) entity))
|
|
(set! (-> obj level) (-> (the-as process arg0) level))
|
|
)
|
|
)
|
|
(set! (-> obj connection-list next1) #f)
|
|
(set! (-> obj connection-list prev1) #f)
|
|
;; set up main thread that can be suspended.
|
|
(set! (-> obj main-thread) (new 'process 'cpu-thread obj 'code 256 arg2))
|
|
;; move to the active pool
|
|
(change-parent obj arg0)
|
|
)
|
|
|
|
(defun run-function-in-process ((obj process) (func function) a0 a1 a2 a3 a4 a5)
|
|
"Switch to the given process and run the function. This is used to initialize a process.
|
|
The function will run until it attempts to change state. At the first attempt to change state,
|
|
this function will return. The idea is that you use this when you want to initialize a process NOW.
|
|
This will then return the value of the function you called!"
|
|
(when (zero? func)
|
|
(format 0 "attempting to run nullptr function!~%")
|
|
(break!)
|
|
)
|
|
(rlet ((pp :reg r13 :type process))
|
|
|
|
(let ((param-array (new 'stack-no-clear 'array 'uint64 6))
|
|
)
|
|
;; copy params to the stack.
|
|
|
|
(set! (-> param-array 0) (the uint64 a0))
|
|
(set! (-> param-array 1) (the uint64 a1))
|
|
(set! (-> param-array 2) (the uint64 a2))
|
|
(set! (-> param-array 3) (the uint64 a3))
|
|
(set! (-> param-array 4) (the uint64 a4))
|
|
(set! (-> param-array 5) (the uint64 a5))
|
|
|
|
(let* ((old-pp pp)
|
|
(func-val (begin
|
|
;; set the process
|
|
(set! pp obj)
|
|
;; set us as initializing
|
|
(set! (-> pp status) 'initialize)
|
|
;; run!
|
|
(the object (new 'stack 'catch-frame 'initialize func param-array))
|
|
)))
|
|
;; the function returned, either through a throw or through actually returning.
|
|
;; the status will give us a clue of what happened.
|
|
(case (-> pp status)
|
|
(('initialize)
|
|
;; we returned and didn't change status.
|
|
(set! (-> pp status) 'initialize-dead)
|
|
;; this means we died, and we should be deactivated.
|
|
(deactivate pp)
|
|
)
|
|
(('initialize-go)
|
|
;; we returned with a (suspend) or (go) ? not sure
|
|
;; either way, we're ready for next time!
|
|
(set! (-> pp status) 'waiting-to-run)
|
|
(when (eq? (-> pp pool type) dead-pool-heap)
|
|
;; we can shrink the heap now.
|
|
(shrink-heap (the dead-pool-heap (-> pp pool)) pp)
|
|
)
|
|
)
|
|
(('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)
|
|
)
|
|
)
|
|
;; decomp deviation
|
|
|
|
(defun set-to-run ((thread cpu-thread) (func function) a0 a1 a2 a3 a4 a5)
|
|
"Set the given thread to call the given function with the given arguments next time it resumes.
|
|
Only for main threads.
|
|
Once the function returns, the process deactivates."
|
|
(let ((proc (-> thread process)))
|
|
(set! (-> proc status) 'waiting-to-run)
|
|
|
|
;; we store arguments and the function to call in saved registers
|
|
(set! (-> thread rreg 0) (the uint func))
|
|
(set! (-> thread rreg 1) (the uint a0))
|
|
(set! (-> thread rreg 2) (the uint a1))
|
|
(set! (-> thread rreg 3) (the uint a2))
|
|
(set! (-> thread rreg 4) (the uint a3))
|
|
(set! (-> thread rreg 5) (the uint a4))
|
|
(set! (-> thread rreg 6) (the uint a5))
|
|
|
|
;; and have the thread first call set-to-run-bootstrap, which will properly call
|
|
;; the function with the arguments and install a return trampoline for
|
|
;; deactivating and returning to the kernel on return.
|
|
(set! (-> thread pc) (the pointer set-to-run-bootstrap))
|
|
;; reset sp.
|
|
(set! (-> thread sp) (-> thread stack-top))
|
|
)
|
|
)
|
|
|
|
(defmethod deactivate process-tree ((obj process-tree))
|
|
(none)
|
|
)
|
|
|
|
;; The defstate macro isn't defined yet, so we do it manually.
|
|
(define dead-state
|
|
(the (state process) (new 'static 'state
|
|
:name 'dead-state
|
|
:next #f
|
|
:exit #f
|
|
:code #f
|
|
:trans #f
|
|
:post #f
|
|
:enter #f
|
|
:event #f)))
|
|
|
|
(set! (-> dead-state code) (the (function none :behavior process) nothing))
|
|
(define entity-deactivate-handler (the-as (function process entity-actor none) nothing))
|
|
|
|
;; decomp deviation
|
|
(defmethod deactivate process ((obj process))
|
|
"Kill a process."
|
|
(with-pp
|
|
;; only if we're not already dead
|
|
(when (!= (-> obj status) 'dead)
|
|
;; set our next-state to dead. We'll run the exit function of the current state, and it can look at this
|
|
;; to tell that process is being killed.
|
|
(set! (-> obj next-state) dead-state)
|
|
|
|
;; clean up entity stuff.
|
|
(if (-> obj entity)
|
|
(entity-deactivate-handler obj (the-as entity-actor (-> obj entity)))
|
|
)
|
|
|
|
;; clean up stack frames. This will run the exit function of the current state
|
|
(let ((s5-0 pp))
|
|
;; set process pointer to the deactivating process, to allow deactivations from another process.
|
|
(set! pp obj)
|
|
(let ((s4-0 (-> pp stack-frame-top)))
|
|
(while (the-as protect-frame s4-0)
|
|
(case (-> s4-0 type)
|
|
((protect-frame state)
|
|
;; run exit function!
|
|
((-> (the-as protect-frame s4-0) exit))
|
|
)
|
|
)
|
|
(set! s4-0 (-> (the-as protect-frame s4-0) next))
|
|
)
|
|
)
|
|
(set! pp s5-0)
|
|
)
|
|
|
|
;; clean up connection/engine stuff
|
|
(if (!= 0 (the uint process-disconnect))
|
|
(process-disconnect obj)
|
|
)
|
|
|
|
;; kill our children
|
|
(let ((v1-12 (-> obj child)))
|
|
(while v1-12
|
|
(let ((s5-1 (-> v1-12 0 brother)))
|
|
(deactivate (-> v1-12 0))
|
|
(set! v1-12 s5-1)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; return process memory to the pool
|
|
(return-process (-> obj pool) obj)
|
|
|
|
;; clear fields to avoid confusion
|
|
(set! (-> obj state) #f)
|
|
(set! (-> obj next-state) #f)
|
|
(set! (-> obj entity) #f)
|
|
(set! (-> obj pid) 0)
|
|
|
|
;; now we have to leave this function...
|
|
(cond
|
|
;; if you deactivated yourself, sneak a 'dead into our status,
|
|
;; then go back to the kernel dispatcher immediately.
|
|
((= (-> *kernel-context* current-process) obj)
|
|
(set! (-> obj status) 'dead)
|
|
(abandon-thread)
|
|
)
|
|
;; if you deactivated yourself while initializing, we should go back to
|
|
;; the place where initialize was called in another process, not all the way back to the kernel.
|
|
((= (-> obj status) 'initialize)
|
|
(set! (-> obj status) 'dead)
|
|
;; the initialization code is protected in a catch block.
|
|
(throw 'initialize #f)
|
|
)
|
|
)
|
|
|
|
;; if you deactivated somebody else, just return as normal
|
|
(set! (-> obj status) 'dead)
|
|
)
|
|
0
|
|
(none)
|
|
)
|
|
)
|
|
;; decomp deviation
|
|
|
|
;;;;;;;;;;;;;;;;;;;
|
|
;; Kernel globals
|
|
;;;;;;;;;;;;;;;;;;;
|
|
|
|
(kmemopen global "process-buffers")
|
|
|
|
;; set up the listener process to run functions sent from the REPL.
|
|
(let ((obj (define *listener-process* (new 'global 'process "listener" 2048))))
|
|
(set! (-> obj status) 'ready)
|
|
(set! (-> obj pid) 1)
|
|
(set! (-> obj main-thread) (new 'process 'cpu-thread obj 'main 256 *kernel-dram-stack*))
|
|
)
|
|
|
|
;; an always dead process used as a placeholder
|
|
(define *null-process* (new 'global 'process "null" 16))
|
|
;; do we have visibility data? This will control warnings about actor memory
|
|
;; and choose which DGOs to load.
|
|
(define *vis-boot* #f)
|
|
;; the default clock
|
|
(define *kernel-clock* (new 'static 'clock))
|
|
;; fixed size dead-pools.
|
|
(define *16k-dead-pool* (new 'global 'dead-pool 2 #x4000 "*16k-dead-pool*"))
|
|
(define *8k-dead-pool* (new 'global 'dead-pool 2 8192 "*8k-dead-pool*"))
|
|
(define *4k-dead-pool* (new 'global 'dead-pool 4 4096 "*4k-dead-pool*"))
|
|
;; special dead pools
|
|
(define *target-dead-pool* (new 'global 'dead-pool 2 #xc000 "*target-dead-pool*"))
|
|
(define *camera-dead-pool* (new 'global 'dead-pool 7 4096 "*camera-dead-pool*"))
|
|
(define *camera-master-dead-pool* (new 'global 'dead-pool 1 8192 "*camera-master-dead-pool*"))
|
|
;; heap dead pools
|
|
(when *debug-segment*
|
|
(define *debug-dead-pool* (new 'debug 'dead-pool-heap "*debug-dead-pool*" 768 #x100000))
|
|
)
|
|
(define *nk-dead-pool* (new 'global 'dead-pool-heap "*nk-dead-pool*" PROCESS_HEAP_MAX PROCESS_HEAP_SIZE))
|
|
;; more special dead pools
|
|
(define *default-dead-pool* (the-as dead-pool *nk-dead-pool*))
|
|
(define *pickup-dead-pool* (the-as dead-pool *nk-dead-pool*))
|
|
(define *city-dead-pool* (new 'loading-level 'dead-pool-heap "*city-dead-pool*" 256 0))
|
|
(define *dead-pool-list* '(*4k-dead-pool*
|
|
*8k-dead-pool*
|
|
*16k-dead-pool*
|
|
*nk-dead-pool*
|
|
*target-dead-pool*
|
|
*camera-dead-pool*
|
|
*camera-master-dead-pool*
|
|
)
|
|
)
|
|
|
|
;; root tree node for all active processes.
|
|
(define *active-pool* (new 'global 'process-tree "active-pool"))
|
|
|
|
;; categories within the active pool.
|
|
(change-parent (define *display-pool* (new 'global 'process-tree "display-pool")) *active-pool*)
|
|
(#when PC_PORT
|
|
(change-parent (define *pc-pool* (new 'global 'process-tree "pc-pool")) *active-pool*)
|
|
(set! (-> *pc-pool* mask) (process-mask freeze pause menu progress process-tree)))
|
|
|
|
(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)
|
|
)
|
|
|
|
|