Archive/jak-project
1
0
Fork 0
mirror of https://github.com/open-goal/jak-project.git synced 2024-10-20 11:26:18 -04:00
Code Issues Actions 3 Packages Projects Releases Wiki Activity
jak-project/goal_src/jak2/kernel/gkernel.gc
ManDude cd68cb671e
deftype and defmethod syntax major changes (#3094) 
Major change to how `deftype` shows up in our code:
- the decompiler will no longer emit the `offset-assert`,
`method-count-assert`, `size-assert` and `flag-assert` parameters. There
are extremely few cases where having this in the decompiled code is
helpful, as the types there come from `all-types` which already has
those parameters. This also doesn't break type consistency because:
  - the asserts aren't compared.
- the first step of the test uses `all-types`, which has the asserts,
which will throw an error if they're bad.
- the decompiler won't emit the `heap-base` parameter unless necessary
now.
- the decompiler will try its hardest to turn a fixed-offset field into
an `overlay-at` field. It falls back to the old offset if all else
fails.
- `overlay-at` now supports field "dereferencing" to specify the offset
that's within a field that's a structure, e.g.:
```lisp
(deftype foobar (structure)
  ((vec    vector  :inline)
   (flags  int32   :overlay-at (-> vec w))
   )
  )
```
in this structure, the offset of `flags` will be 12 because that is the
final offset of `vec`'s `w` field within this structure.
- **removed ID from all method declarations.** IDs are only ever
automatically assigned now. Fixes #3068.
- added an `:overlay` parameter to method declarations, in order to
declare a new method that goes on top of a previously-defined method.
Syntax is `:overlay <method-name>`. Please do not ever use this.
- added `state-methods` list parameter. This lets you quickly specify a
list of states to be put in the method table. Same syntax as the
`states` list parameter. The decompiler will try to put as many states
in this as it can without messing with the method ID order.

Also changes `defmethod` to make the first type definition (before the
arguments) optional. The type can now be inferred from the first
argument. Fixes #3093.

---------

Co-authored-by: Hat Kid <6624576+Hat-Kid@users.noreply.github.com>
2023-10-30 03:20:02 +00:00

2504 lines
82 KiB
Common Lisp
Raw Blame History

;;-*-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))
(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 ((this object) (arg0 int))
"Most general relocate method."
this
)
;;;;;;;;;;;;;;;;;;
;; 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
;;;;;;;;;;;;;;;;;;;;;;;
;; og:preserve-this
;; 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 ((this thread))
"Restore the previous thread as the top-thread."
;; make sure we aren't actually trying to delete the main thread.
(when (= this (-> this process main-thread))
(break!)
)
(set! (-> this process top-thread) (the-as cpu-thread (-> this previous)))
(none)
)
(defmethod print ((this thread))
(format #t "#<~A ~S of ~S pc: #x~X @ #x~X>" (-> this type) (-> this name) (-> this process name) (-> this pc) this)
this
)
(defmethod stack-size-set! ((this thread) (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 (-> this process)))
(cond
((!= this (-> a2-0 main-thread))
(format 0 "ERROR: illegal attempt change stack size of ~A when the main-thread is not the top-thread.~%" a2-0)
)
((= (-> this stack-size) arg0)
)
((= (-> a2-0 heap-cur) (+ (+ (-> this stack-size) -4 (-> this type size)) (the-as int this)))
(set! (-> a2-0 heap-cur) (the-as pointer (+ (+ arg0 -4 (-> this type size)) (the-as int this))))
(set! (-> this 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 ((this cpu-thread))
"Get the size in memory of a cpu-thread."
(the-as int (+ (-> this type size) (-> this 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 ((this process-tree))
"Print a process tree."
(format #t "#<~A ~S @ #x~X>" (-> this type) (-> this name) this)
this
)
(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 ((this process-tree))
"Inspect a process-tree"
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~Tname: ~S~%" (-> this name))
(format #t "~1Tmask: #x~X : (process-mask " (-> this mask))
(stream<-process-mask #t (-> this mask))
(format #t ")~%")
(format #t "~Tclock: ~A~%" (-> this clock))
(format #t "~Tparent: ~A~%" (ppointer->process (-> this parent)))
(format #t "~Tbrother: ~A~%" (ppointer->process (-> this brother)))
(format #t "~Tchild: ~A~%" (ppointer->process (-> this child)))
this
)
(defmethod new process ((allocation symbol) (type-to-make type) (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 ((this process))
"Inspect each object on the process heap."
(let ((ptr (&+ (-> this heap-base) *gtype-basic-offset*))) ; point to first basic
;; loop over objects
(while (< (the int ptr) (the int (-> this 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 ((this process))
"Inspect process and all objects on the heap.. Autogenerated process inspects will eventually call this one."
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~Tname: ~S~%" (-> this name))
(format #t "~1Tmask: #x~X : (process-mask " (-> this mask))
(stream<-process-mask #t (-> this mask))
(format #t ")~%")
(format #t "~Tclock: ~A~%" (-> this clock))
(format #t "~Tstatus: ~A~%" (-> this status))
(format #t "~Tmain-thread: ~A~%" (-> this main-thread))
(format #t "~Ttop-thread: ~A~%" (-> this top-thread))
(format #t "~Tentity: ~A~%" (-> this entity))
(format #t "~Tlevel: ~A~%" (-> this level))
(format #t "~Tstate: ~A~%" (-> this state))
(format #t "~Tnext-state: ~A~%" (-> this next-state))
(format #t "~Ttrans-hook: ~A~%" (-> this trans-hook))
(format #t "~Tpost-hook: ~A~%" (-> this post-hook))
(format #t "~Tevent-hook: ~A~%" (-> this event-hook))
(format #t "~Tparent: ~A~%" (ppointer->process (-> this parent)))
(format #t "~Tbrother: ~A~%" (ppointer->process (-> this brother)))
(format #t "~Tchild: ~A~%" (ppointer->process (-> this child)))
(format #t "~Tconnection-list: ~`connectable`P~%" (-> this connection-list))
(format #t "~Tstack-frame-top: ~A~%" (-> this stack-frame-top))
(format #t "~Theap-base: #x~X~%" (-> this heap-base))
(format #t "~Theap-top: #x~X~%" (-> this heap-top))
(format #t "~Theap-cur: #x~X~%" (-> this heap-cur))
(let ((s5-0 *print-column*))
(set! *print-column* (+ *print-column* *tab-size*))
(format #t "----~%")
(inspect-process-heap this)
(format #t "----~%")
(set! *print-column* s5-0)
)
(format #t "~Tallocated-length: ~D~%" (-> this allocated-length))
(format #t "~Tstack[~D] @ #x~X~%" (-> this allocated-length) (-> this stack))
this
)
(defmethod asize-of ((this process))
"Get the size in memory of a process."
(the-as int (+ (-> process size) (-> this allocated-length)))
)
(defmethod print ((this 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 (-> this top-thread) (!= (-> this status) 'dead))
(format #t "#<~A ~S ~A :state ~S "
(-> this type)
(-> this name)
(-> this status)
(if (-> this state) (-> this state name))
)
(format #t ":stack ~D/~D :heap ~D/~D @ #x~X>"
(&- (-> this top-thread stack-top) (the-as uint (-> this top-thread sp)))
(-> this main-thread stack-size)
(- (-> this allocated-length) (&- (-> this heap-top) (the-as uint (-> this heap-cur))))
(-> this allocated-length)
this
)
)
(else
(format #t "#<~A ~S ~A :state ~S @ #x~X"
(-> this type)
(-> this name)
(-> this status)
(if (-> this state)
(-> this state name)
)
this
)
)
)
this
)
;; 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 ((this thread) (func function))
"Make the given thread the top thread, reset the stack, and call the function.
Sets up a return trampoline so when the function returns it will return to the
kernel context. Will NOT deactivate on return, so this is intended for temporary threads.
NOTE: this should only be done from the kernel, running on the
kernel's stack."
(declare (asm-func object)
)
(rlet ((pp :reg r13 :type process)
(sp :reg rsp :type uint)
(off :reg r15 :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp :reg rax :type uint)
)
;; set up the process pointer
(set! pp (-> this process))
;; mark the process as running and set its top thread
(set! (-> pp status) 'running)
(set! (-> pp top-thread) (the cpu-thread this))
;; save the current kernel regs
(.push :color #f s0)
(.push :color #f s1)
(.push :color #f s2)
(.push :color #f s3)
(.push :color #f s4)
;; make rsp a GOAL pointer
(.sub sp off)
;; and store it
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
;; setup the rsp for the new thread
(set! sp (the uint (-> this stack-top)))
(.add sp off)
;; push the return trampoline to the stack for the user code to return to
(set! temp (the uint return-from-thread))
(.add temp off)
(.push temp) ;; stack now 16 + 8 aligned
;; and call the function!
(.add func off)
(.jr func)
)
)
(defmethod thread-suspend ((unused cpu-thread))
"Suspend the thread and return to the kernel."
(declare (asm-func none))
;; we begin this function with the thread object in pp.
;; not sure why we do this, maybe at one point suspending didn't clobber
;; temp registers?
(rlet ((this :reg r13 :type cpu-thread)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; get the return address pushed by "call" in the suspend.
(.pop temp)
;; convert to a GOAL address
(.sub temp off)
;; store return address in thread
(set! (-> this pc) (the pointer temp))
;; convert our stack pointer to a GOAL address
(.sub sp off)
;; store in thread.
(set! (-> this sp) (the pointer sp))
;; back up registers
(.mov :color #f temp s0)
(set! (-> this rreg 0) temp)
(.mov :color #f temp s1)
(set! (-> this rreg 1) temp)
(.mov :color #f temp s2)
(set! (-> this rreg 2) temp)
(.mov :color #f temp s3)
(set! (-> this rreg 3) temp)
(.mov :color #f temp s4)
(set! (-> this rreg 4) temp)
;; back up fprs
(.mov :color #f temp xmm8)
(set! (-> this freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> this freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> this freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> this freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> this freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> this freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> this freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> this freg 7) (the-as float temp))
;; get our process
(let ((proc (-> this process)))
(when (> (process-stack-used proc) (-> this stack-size))
(break) ;; too much stack has been used and we can't suspend!
;; if you hit this, try with DEBUG_PRINT_SUSPEND_FAIL set to #t (see gkernel-h.gc)
;; it will print more info before reaching here.
)
;; mark the process as suspended and copy the stack
(set! (-> proc status) 'suspended)
(let ((cur (the (pointer uint64) (-> this stack-top)))
(save (&+ (the (pointer uint64) (-> this stack)) (-> this stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! save (the (pointer uint64) (&- save 8)))
(set! (-> save) (-> cur))
)
)
)
;; actually setting pp to 0
(set! this (the cpu-thread 0))
;; get the kernel stack pointer as a GOAL pointer
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating".
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
(.ret)
)
(none)
)
(defmethod thread-resume ((thread-to-resume cpu-thread))
"Resume a suspended thread. Call this from the kernel only.
This is also used to start a thread initialized with set-to-run.
As a result of MIPS/x86 differences, there is a hack for this."
(declare (asm-func none)
;;(print-asm)
)
(rlet ((this :reg r13 :type cpu-thread)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(a4 :reg r8 :type uint)
(a5 :reg r9 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; save the current kernel regs
(.push :color #f s0)
(.push :color #f s1)
(.push :color #f s2)
(.push :color #f s3)
(.push :color #f s4)
;; make rsp a GOAL pointer
(.sub sp off)
;; and store it
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
;; temp, stash thread in process-pointer
(set! this thread-to-resume)
;; set stack pointer for the thread. leave it as a GOAL pointer for now..
(set! sp (the uint (-> this sp)))
;; restore the stack (sp is a GOAL pointer)
(let ((cur (the (pointer uint64) (-> this stack-top)))
(restore (&+ (the (pointer uint64) (-> this stack)) (-> this stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! restore (the (pointer uint64) (&- restore 8)))
(set! (-> cur) (-> restore))
)
)
;; offset sp after we're done using it as a GOAL pointer.
(.add sp off)
;; setup process
(set! (-> (-> this process) top-thread) this)
(set! (-> (-> this process) status) 'running)
;; restore reg
(set! temp (-> this rreg 0))
(.mov :color #f s0 temp)
(set! temp (-> this rreg 1))
(.mov :color #f s1 temp)
(set! temp (-> this rreg 2))
(.mov :color #f s2 temp)
(set! temp (-> this rreg 3))
(.mov :color #f s3 temp)
(set! temp (-> this rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> this freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> this freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> this freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> this freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> this freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> this freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> this freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> this freg 7))
(.mov :color #f xmm15 temp-float)
;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
;; expects to receive 7 values from the cpu thread's rregs.
;; usually rreg holds saved registers, but on the first resume after
;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
;; We only have 5 saved regs, so we need to cheat and directly pass
;; two values in other registers
;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
;; In the case where we are doing a normal resume, the
;; compiler should assume that these registers are overwritten anyway.
(set! temp (-> this rreg 5))
(.mov a4 temp)
(set! temp (-> this rreg 6))
(.mov a5 temp)
;; get the resume address
(set! temp (the uint (-> this pc)))
(.add temp off)
;; setup the process
(set! this (the cpu-thread (-> this process)))
;; resume!
(.jr temp)
(.add a4 a4)
(.add a5 a5)
)
(none)
)
;; 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
)
)
;; og:preserve-this decomp deviation
(defmethod get-process ((this 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 (-> this child))))
(when (and (not (the-as (pointer process-tree) s4-0)) *debug-segment* (!= this *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
(-> this 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))
(-> this name)
)
(the-as process #f)
)
)
)
)
;; decomp deviation
(defmethod return-process ((this dead-pool) (arg0 process))
"Return a process to the dead pool."
(change-parent arg0 this)
(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 ((this 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 (-> this allocated-length))
(let ((a0-4 (-> this process-list v1-0)))
(set! (-> a0-4 process) *null-process*)
(set! (-> a0-4 next) (-> this process-list (+ v1-0 1)))
)
)
;; set the dead list to that list
(set! (-> this dead-list next) (the-as dead-pool-heap-rec (-> this process-list)))
;; clear alive list
(set! (-> this alive-list process) #f)
;; terminate dead list.
(set! (-> this process-list (+ (-> this allocated-length) -1) next) #f)
(set! (-> this alive-list prev) (-> this alive-list))
(set! (-> this alive-list next) #f)
(set! (-> this alive-list process) #f)
(set! (-> this first-gap) (-> this alive-list))
(set! (-> this first-shrink) #f)
(cond
((zero? arg1)
;; explicit support for a 0 size heap.
(set! (-> this heap base) (the-as pointer 0))
(set! (-> this heap current) (the-as pointer 0))
(set! (-> this heap top) (the-as pointer 0))
(set! (-> this heap top-base) (the-as pointer 0))
0
)
(else
;; otherwise allocate a heap.
(set! (-> this heap base) (malloc arg0 arg1))
(set! (-> this heap current) (-> this heap base))
(set! (-> this heap top) (&+ (-> this heap base) arg1))
(set! (-> this heap top-base) (-> this heap top))
)
)
(none)
)
(defmethod gap-location ((this 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.
(-> this heap base)
)
)
)
(defmethod gap-size ((this 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.
(&- (-> this 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 (&+ (-> this heap base) 4)))
)
(else
;; no processes at all, the gap is the entire heap.
(&- (-> this heap top) (the-as uint (-> this heap base)))
)
)
)
(defmethod find-gap ((this 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 this arg0)))
(set! arg0 (-> arg0 next))
)
arg0
)
(defmethod inspect ((this dead-pool-heap))
"Inspect a dead-pool heap, printing proccesses and gaps."
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~Tname: ~A~%" (-> this name))
(format #t "~1Tmask: #x~X : (process-mask " (-> this mask))
(stream<-process-mask #t (-> this mask))
(format #t ")~%")
(format #t "~Tparent: #x~X~%" (-> this parent))
(format #t "~Tbrother: #x~X~%" (-> this brother))
(format #t "~Tchild: #x~X~%" (-> this child))
(format #t "~Tppointer: #x~X~%" (-> this ppointer))
(format #t "~Tself: ~A~%" (-> this self))
(format #t "~Tallocated-length: ~D~%" (-> this allocated-length))
(format #t "~Theap: #<kheap @ #x~X>~%" (-> this heap))
(format #t "~Tfirst-gap: #<dead-pool-heap-rec @ #x~X>~%" (-> this first-gap))
(format #t "~Tfirst-shrink: #<dead-pool-heap-rec @ #x~X>~%" (-> this first-shrink))
(format #t "~Talive-list: #<dead-pool-heap-rec @ #x~X>~%" (-> this alive-list))
(format #t "~Tlast: #<dead-pool-heap-rec @ #x~X>~%" (-> this alive-list prev))
(format #t "~Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> this dead-list))
(let* ((s5-0 (&- (-> this heap top) (the-as uint (-> this heap base))))
(v1-3 (if (-> this alive-list prev)
(gap-size this (-> this alive-list prev))
s5-0
)
)
)
(format #t "~Tprocess-list[0] @ #x~X ~D/~D bytes used~%" (-> this process-list) (- s5-0 v1-3) s5-0)
)
(let ((s5-1 (-> this alive-list))
(s4-0 0)
)
(while s5-1
(if (-> s5-1 process)
(format #t "~T [~3D] #<dead-pool-heap-rec @ #x~X> ~A~%" s4-0 s5-1 (-> s5-1 process))
)
(let ((s3-0 (gap-size this s5-1)))
(if (nonzero? s3-0)
(format #t "~T gap: ~D bytes @ #x~X~%" s3-0 (gap-location this s5-1))
)
)
(set! s5-1 (-> s5-1 next))
(+! s4-0 1)
)
)
this
)
(defmethod asize-of ((this dead-pool-heap))
"Get the size in memory of a dead-pool-heap."
(the-as int (+ (-> this type size) (* 12 (-> this allocated-length))))
)
(defmethod memory-used ((this dead-pool-heap))
"Get the amount of used memory. Gaps in between processes are considered used."
(if (-> this alive-list prev)
(- (memory-total this) (gap-size this (-> this alive-list prev)))
0
)
)
(defmethod memory-total ((this dead-pool-heap))
"Get the total size of the heap."
(&- (-> this heap top) (the-as uint (-> this heap base)))
)
(defmethod memory-free ((this dead-pool-heap))
"Get the amount of free memory. Does not include gaps in between processes."
(let ((v1-0 (-> this heap top)))
(if (-> this alive-list prev)
(gap-size this (-> this alive-list prev))
(&- v1-0 (the-as uint (-> this heap base)))
)
)
)
(defmethod compact-time ((this dead-pool-heap))
"Not working, likely was supposed to return how long the compaction took."
;; never set.
(-> this compact-time)
)
(defmethod find-gap-by-size ((this dead-pool-heap) (arg0 int))
"Find the first gap which is at least the given size."
(let ((gp-0 (-> this first-gap)))
(while (and gp-0 (< (gap-size this gp-0) arg0))
(set! gp-0 (-> gp-0 next))
)
gp-0
)
)
(defmethod get-process ((this dead-pool-heap) (arg0 type) (arg1 int))
"Get a process!"
(let ((s4-0 (-> this dead-list next))
(s3-0 (the-as process #f))
)
;; find a gap!
(let ((s1-0 (find-gap-by-size this (the-as int (+ (-> process size) arg1)))))
(cond
((and s4-0 s1-0 (nonzero? (-> this heap base))) ;; have record, gap, and heap, we are good!
;; get record
(set! (-> this 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 (-> this alive-list prev))
(set! (-> this alive-list prev) s4-0)
)
;; construct process in-place
(let ((a0-5 (gap-location this 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 (= (-> this first-gap) s1-0)
(set! (-> this first-gap) (find-gap this s4-0))
)
(if (or (not (-> this first-shrink)) (< (the-as int s3-0) (the-as int (-> this first-shrink process))))
(set! (-> this first-shrink) s4-0)
)
;; setup process
(set! (-> s3-0 parent) (-> this ppointer))
(set! (-> s3-0 pool) this)
(set! (-> this child) (&-> s4-0 process))
)
(else
(when (and *debug-segment* (!= this *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
(-> this 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 (-> this name))
)
s3-0
)
)
;; decomp deviation
(defmethod return-process ((this dead-pool-heap) (proc process))
"Return a process to a dead pool heap"
;; check we are returning to the correct pool
(unless (eq? this (-> proc pool))
(format 0 "ERROR: process ~A does not belong to dead-pool-heap ~A.~%" proc this)
)
;; reclaim us.
(change-parent proc this)
;; we don't maintain a real tree for a dead-pool-heap, so undo any change to child
;; done by change-parent
(set! (-> this 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? (-> this first-gap) rec)
(< (the int (gap-location this rec)) (the int (gap-location this (-> this first-gap))))
)
(set! (-> this first-gap) (-> rec prev))
)
;; update the first-shrink. We aren't smart about this and just move it backward.
(when (eq? (-> this first-shrink) rec)
(set! (-> this first-shrink) (-> rec prev))
(when (not (-> this first-shrink process))
(set! (-> this 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! (-> this last) (-> rec prev))
)
)
;; insert at the front of the dead list.
(set! (-> rec next) (-> this dead-list next))
(set! (-> this dead-list next) rec)
(set! (-> rec process) *null-process*)
(none)
)
)
(defmethod shrink-heap ((this 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 this (-> this first-gap))))
(set! (-> this first-gap) (find-gap this rec))
)
;; mark us as shrunk
(process-mask-set! (-> proc mask) heap-shrunk)
)
;; update first shrink
(when (eq? (-> this first-shrink) rec)
(set! (-> this first-shrink) (-> rec next))
)
)
)
this
)
;; decomp deviation
(defmethod compact ((this 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? (-> this heap base))
(return 0)
)
;; if we're almost out of memory, increase the compaction amount.
(let* ((s4-0 (memory-free this))
(v1-5 (memory-total this))
(f0-2 (/ (the float s4-0) (the float v1-5)))
)
(cond
((< f0-2 0.1)
(set! 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! (-> this compact-count-targ) (the-as uint arg0))
(set! (-> this compact-count) (the-as uint 0))
;; loop over compactions.
(while (nonzero? arg0)
(+! arg0 -1)
;; try to get something to shrink
(let ((v1-19 (-> this first-shrink)))
(when (not v1-19)
(set! v1-19 (-> this alive-list next))
(set! (-> this first-shrink) v1-19)
)
(if v1-19
;; got something, shrink it.
(shrink-heap this (-> v1-19 process))
)
)
;; move to fill the gap.
(let ((s4-1 (-> this first-gap)))
(when (-> s4-1 next)
(let ((s3-0 (-> s4-1 next process))
(s2-0 (gap-size this s4-1))
)
(when (nonzero? s2-0)
(when (< s2-0 0)
;; bug, negative size.
(break!)
)
;; shrink before moving.
(shrink-heap this s3-0)
;; do the relocation! the relocate method of process does the actual memcpy.
(relocate s3-0 (- s2-0))
;; update gaps
(set! (-> this first-gap) (find-gap this s4-1))
(+! (-> this compact-count) 1)
)
)
)
)
)
0
(none)
)
(defmethod churn ((this dead-pool-heap) (arg0 int))
"Relocate processes to debug process relocation."
(while (nonzero? arg0)
(+! arg0 -1)
(let ((s4-0 (-> this alive-list next)))
(when s4-0
(if (or (= (-> this first-gap) s4-0)
(< (the-as int (gap-location this s4-0)) (the-as int (gap-location this (-> this first-gap))))
)
(set! (-> this first-gap) (-> s4-0 prev))
)
(when (= (-> this first-shrink) s4-0)
(set! (-> this first-shrink) (-> s4-0 prev))
(if (not (-> this first-shrink process))
(set! (-> this first-shrink) #f)
)
)
(set! (-> s4-0 prev next) (-> s4-0 next))
(if (-> s4-0 next)
(set! (-> s4-0 next prev) (-> s4-0 prev))
(set! (-> this alive-list prev) (-> s4-0 prev))
)
(let ((a1-3 (-> this alive-list prev)))
(let ((v1-19 (-> a1-3 next)))
(set! (-> a1-3 next) s4-0)
(set! (-> s4-0 next) v1-19)
(if v1-19
(set! (-> v1-19 prev) s4-0)
)
)
(set! (-> s4-0 prev) a1-3)
(set! (-> this alive-list prev) s4-0)
(set! (-> s4-0 process)
(relocate (-> s4-0 process) (&- (gap-location this a1-3) (the-as uint (&-> (-> s4-0 process) type))))
)
)
)
)
)
0
(none)
)
(defun method-state ((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)
(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))
(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? ((this 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 (not (logtest? (-> 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 (the process 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 #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 ((this (the catch-frame (&+ (the pointer allocation) *gtype-basic-offset*))))
;; setup catch frame
(set! (-> this type) type-to-make)
(set! (-> this name) name)
;; get the return address (the compiler won't touch the stack because we're an asm-func)
(.pop temp)
(.push temp)
;; make it a GOAL address so it fits in 32 bits
(.sub temp off)
;; store it
(set! (-> this ra) (the int temp))
;; todo, do we need a stack offset here?
;; remember the stack pointer
(set! temp sp)
(.sub temp off)
(set! (-> this sp) (the int temp))
;; back up registers we care about
(.mov :color #f temp s0)
(set-u128-as-u64! (-> this rreg 0) temp)
(.mov :color #f temp s1)
(set-u128-as-u64! (-> this rreg 1) temp)
(.mov :color #f temp s2)
(set-u128-as-u64! (-> this rreg 2) temp)
(.mov :color #f temp s3)
(set-u128-as-u64! (-> this rreg 3) temp)
(.mov :color #f temp s4)
(set-u128-as-u64! (-> this rreg 4) temp)
(.mov :color #f temp xmm8)
(set! (-> this freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> this freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> this freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> this freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> this freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> this freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> this freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> this freg 7) (the-as float temp))
;; push this stack frame
(set! (-> this next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) this)
;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
(.push :color #f s3)
(.push :color #f s2)
(.push :color #f s2)
(set! s3 (the uint func))
(set! s2 param-block)
;; todo - are we aligned correctly here?
(let ((ret ((the-super-u64-fucntion s3)
(-> s2 0)
(-> s2 1)
(-> s2 2)
(-> s2 3)
(-> s2 4)
(-> s2 5)
))
)
(.pop :color #f s2)
(.pop :color #f s2)
(.pop :color #f s3)
(set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
(.ret)
(the object ret)
)
)
)
)
(defun throw-dispatch ((this catch-frame) value)
"Throw the given value to the catch frame.
Only can throw a 64-bit value. The original could throw 128 bits."
(declare (asm-func none))
(rlet ((pp :reg r13 :type process)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type (pointer uint64))
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; pop everything we threw past
(set! (-> pp stack-frame-top) (-> this next))
;; restore regs we care about.
(set-u64-from-u128! temp (-> this rreg 0))
(.mov :color #f s0 temp)
(set-u64-from-u128! temp (-> this rreg 1))
(.mov :color #f s1 temp)
(set-u64-from-u128! temp (-> this rreg 2))
(.mov :color #f s2 temp)
(set-u64-from-u128! temp (-> this rreg 3))
(.mov :color #f s3 temp)
(set-u64-from-u128! temp (-> this rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> this freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> this freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> this freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> this freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> this freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> this freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> this freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> this freg 7))
(.mov :color #f xmm15 temp-float)
;; set stack pointer
(set! sp (the uint (-> this sp)))
(.add sp off)
;; overwrite our return address
(.pop temp)
(set! temp (the uint (-> this ra)))
(.add temp off)
(.push temp)
;; load the return register
(.mov temp value)
(.ret)
)
)
(defun throw ((name symbol) value)
"Dynamic throw."
(rlet ((pp :reg r13 :type process))
(let ((cur (-> pp stack-frame-top)))
(while cur
(when (and (eq? (-> cur name) name) (eq? (-> cur type) catch-frame))
;; match!
(throw-dispatch (the catch-frame cur) value)
)
(if (eq? (-> cur type) protect-frame)
;; call the cleanup function
((-> (the protect-frame cur) exit))
)
(set! cur (-> cur next))
)
)
)
(format 0 "ERROR: throw could not find tag ~A~%" name)
(break)
)
;; decomp deviation
(defmethod new protect-frame ((allocation symbol) (type-to-make type) (arg0 (function object)))
"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 ((this 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! (-> this mask) (logclear (-> arg0 mask) (process-mask sleep sleep-code process-tree heap-shrunk)))
;; inherit clock
(set! (-> this clock) (-> arg0 clock))
(set! (-> this status) 'ready)
;; get unique pid
(let ((v1-5 (-> *kernel-context* next-pid)))
(set! (-> this pid) v1-5)
(set! (-> *kernel-context* next-pid) (+ v1-5 1))
)
(set! (-> this top-thread) #f)
(set! (-> this main-thread) #f)
(set! (-> this name) (the-as string arg1))
;; adjust heap to leave a gap for child of process fields
(let ((v1-10 (&-> this stack (-> this type heap-base))))
(set! (-> this heap-cur) v1-10)
(set! (-> this heap-base) v1-10)
)
(set! (-> this stack-frame-top) #f)
;; clear the heap
(mem-set32! (-> this stack) (the-as int (shr (-> this type heap-base) 2)) 0)
(set! (-> this trans-hook) #f)
(set! (-> this post-hook) #f)
(set! (-> this event-hook) #f)
(set! (-> this state) #f)
(set! (-> this next-state) #f)
(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! (-> this entity) #f)
(set! (-> this level) *default-level*)
)
(else
;; parent is another process, inherit level/entity.
(set! (-> this entity) (-> (the-as process arg0) entity))
(set! (-> this level) (-> (the-as process arg0) level))
)
)
(set! (-> this connection-list next1) #f)
(set! (-> this connection-list prev1) #f)
;; set up main thread that can be suspended.
(set! (-> this main-thread) (new 'process 'cpu-thread this 'code 256 arg2))
;; move to the active pool
(change-parent this arg0)
)
(defun run-function-in-process ((this process) (func function) a0 a1 a2 a3 a4 a5)
"Switch to the given process and run the function. This is used to initialize a process.
The function will run until it attempts to change state. At the first attempt to change state,
this function will return. The idea is that you use this when you want to initialize a process NOW.
This will then return the value of the function you called!"
(when (zero? func)
(format 0 "attempting to run nullptr function!~%")
(break!)
)
(rlet ((pp :reg r13 :type process))
(let ((param-array (new 'stack-no-clear 'array 'uint64 6))
)
;; copy params to the stack.
(set! (-> param-array 0) (the uint64 a0))
(set! (-> param-array 1) (the uint64 a1))
(set! (-> param-array 2) (the uint64 a2))
(set! (-> param-array 3) (the uint64 a3))
(set! (-> param-array 4) (the uint64 a4))
(set! (-> param-array 5) (the uint64 a5))
(let* ((old-pp pp)
(func-val (begin
;; set the process
(set! pp this)
;; set us as initializing
(set! (-> pp status) 'initialize)
;; run!
(the object (new 'stack 'catch-frame 'initialize func param-array))
)))
;; the function returned, either through a throw or through actually returning.
;; the status will give us a clue of what happened.
(case (-> pp status)
(('initialize)
;; we returned and didn't change status.
(set! (-> pp status) 'initialize-dead)
;; this means we died, and we should be deactivated.
(deactivate pp)
)
(('initialize-go)
;; we returned with a (suspend) or (go) ? not sure
;; either way, we're ready for next time!
(set! (-> pp status) 'waiting-to-run)
(when (eq? (-> pp pool type) dead-pool-heap)
;; we can shrink the heap now.
(shrink-heap (the dead-pool-heap (-> pp pool)) pp)
)
)
(('dead)
;; died in init, this is fine.
)
(else
(format 0 "GOT UNKNOWN INIT: ~A~%" (-> pp status))
)
)
;; restore the old pp
(set! pp old-pp)
func-val
)
)
)
)
(defun set-to-run-bootstrap ()
"This function is a clever hack.
To reset a thread to running a new function, we stash the arguments as saved registers.
These are then restored by thread-resume on the next run of the kernel.
This stub remaps these saved registers to argument registers.
It also creates a return trampoline to return-from-thread-dead, so if the main thread returns, the
process is properly cleaned up by deactivate."
(declare (asm-func none)
;;(print-asm)
)
(rlet ((s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(a0 :reg rdi :type uint) ; ok
(a1 :reg rsi :type uint) ; ok
(a2 :reg rdx :type uint) ; ok
(a3 :reg rcx :type uint) ; ok
(off :reg r15 :type uint)
(a4 :reg r8 :type uint)
(a5 :reg r9 :type uint)
(temp :reg rax)
)
(.mov temp return-from-thread-dead)
(.add temp off)
(.push temp)
;; stack is 16 + 8 aligned now
(.mov :color #f a0 s1)
(.mov :color #f a1 s2)
(.mov :color #f a2 s3)
(.mov :color #f a3 s4)
(.add :color #f s0 off)
(.jr :color #f s0)
(.add a4 a4)
(.add a5 a5)
)
)
;; 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 ((this 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 object :behavior process) nothing))
(define entity-deactivate-handler (the-as (function process entity-actor none) nothing))
;; decomp deviation
(defmethod deactivate ((this process))
"Kill a process."
(with-pp
;; only if we're not already dead
(when (!= (-> this 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! (-> this next-state) dead-state)
;; clean up entity stuff.
(if (-> this entity)
(entity-deactivate-handler this (the-as entity-actor (-> this 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 this)
(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 this)
)
;; kill our children
(let ((v1-12 (-> this child)))
(while v1-12
(let ((s5-1 (-> v1-12 0 brother)))
(deactivate (-> v1-12 0))
(set! v1-12 s5-1)
)
)
)
;; return process memory to the pool
(return-process (-> this pool) this)
;; clear fields to avoid confusion
(set! (-> this state) #f)
(set! (-> this next-state) #f)
(set! (-> this entity) #f)
(set! (-> this 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) this)
(set! (-> this 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.
((= (-> this status) 'initialize)
(set! (-> this status) 'dead)
;; the initialization code is protected in a catch block.
(throw 'initialize #f)
)
)
;; if you deactivated somebody else, just return as normal
(set! (-> this 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 ((this (define *listener-process* (new 'global 'process "listener" 2048))))
(set! (-> this status) 'ready)
(set! (-> this pid) 1)
(set! (-> this main-thread) (new 'process 'cpu-thread this '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)
)
Reference in a new issue View git blame Copy permalink